AROP:
- ✅ vzít ekvivalizované příjmy domácností
- ✅ přepočítat je na příjmy v PPP/PPS (srovnatelnou currency z
hlediska, co si za ní koupíš)
- ✅ spočítat 60 % evropského mediánu
- ✅ spočítat, kolik domácností v různých zemí je pod
- ✅ jak se to liší od běžné AROP národní
- ✅ focus na ČR - jak se české a evropské AROP liší v různých typech
domácností
- nice to haves:
- jak se tím změní AROPE - ukazatel, který zahrnuje AROP OR těžká
materiální deprivace OR dlouhodobá nezaměstnanost, a v poslední dobe je
používanější a vytvuří zdání robustnosti, ale je destruován tím
AROP
- ✅ jak se změní vývoj v čase - zvětšuje se evropská chudoba v ČR
(např. proti roku 2018, 2019)
Power Purchasing Parity je odsud.
V SILCu jsou příjmy domácností v eurech, pro země, které nepřijaly euro, je potřeba převést příjmy do národní měny. Měnové kurzy jsou odsud.
library(gt)
library(DT)
library(paqr)
library(dplyr)
library(corrr)
library(Hmisc)
library(haven)
library(readxl)
library(eulerr)
library(ggtext)
library(targets)
library(ggplot2)
library(ggrepel)
library(ggridges)
library(DescTools)
library(patchwork)
tar_load(r_silc_2023)
hh_r_silc_2023 <- r_silc_2023 %>%
group_by(country, hh_id) %>%
mutate(
n_retired = sum(econ_status == "Retired", na.rm = TRUE),
n_employed = sum(econ_status == "Employed", na.rm = TRUE),
n_adults = sum(age >= 18),
n_old_age = sum(age >= 65),
income_disposable = if_else(income_disposable < 0, 0, income_disposable),
income_disposable_eqi = if_else(income_disposable_eqi < 0, 0, income_disposable_eqi)
) %>%
slice(1) %>%
ungroup() %>%
mutate(across(where(is.character), ~haven::as_factor(.x))) %>%
# filter out EU countries only
filter(country != "Norway") %>%
mutate(
country = fct_case_when(
country == "Oesterreich" ~ "Austria",
country == "Belgique" ~ "Belgium",
country == "Deutschland" ~ "Germany",
country == "Danmark" ~ "Denmark",
country == "Ellada" ~ "Greece",
country == "Espana" ~ "Spain",
country == "Suomi" ~ "Finland",
country == "Nederland" ~ "Netherlands",
country == "Sverige" ~ "Sweden",
country == "Italia" ~ "Italy",
country == "Czech Republic" ~ "Czechia",
country == "Slovak Republic" ~ "Slovakia",
TRUE ~ country
),
r_tenure_status = fct_case_when(
grepl("Tenant", tenure_status) ~ "Tenant",
grepl("Owner", tenure_status) ~ "Owner"
)
) %>%
mutate(
hh_retired = fct_case_when(
n_retired == n_persons ~ "Plně důchodcovská domácnost",
n_retired > 0 ~ "Domácnost s důchodcem",
n_retired == 0 ~ "Domácnost bez důchodců"
),
hh_old = fct_case_when(
n_old_age == n_persons ~ "Všichni 65+",
n_old_age > 0 ~ "Alespoň jeden 65+",
n_old_age == 0 ~ "Bez 65+"
),
typ_domacnosti = fct_case_when(
n_adults == 2 & n_children > 0 ~ "Úplná domácnost s dětmi",
n_adults == 1 & n_children > 0 ~ "Samoživitel/ka s dětmi",
n_adults == 2 & hh_retired == "Plně důchodcovská domácnost" ~ "Dvojice seniorů",
n_adults == 1 & hh_retired == "Plně důchodcovská domácnost" ~ "Samostatně žijící senior",
TRUE ~ "Ostatní"
)
)
regiony <- hh_r_silc_2023 %>%
filter(region != "info not provided for DE, NL, PT, RS") %>%
group_by(country, region) %>%
summarise(mean_income = mean(income_disposable_eqi)) %>%
group_by(country) %>%
filter(mean_income == max(mean_income) | mean_income == min(mean_income)) %>%
mutate(
n = n(),
region_typ = case_when(
mean_income == max(mean_income) ~ "nejbohatší region",
mean_income == min(mean_income) ~ "nejchudší region"
)
) %>%
filter(n == 2) %>%
ungroup %>%
select(country, region, region_typ)
exchange_rates <- read_excel("data/exchange_rates.xlsx", sheet = 3, skip = 8) %>%
select(currency = TIME, exchange_rate_2022 = `2022`) %>%
filter(!is.na(currency)) %>%
mutate(country = case_when(
currency == "Bulgarian lev" ~ "Bulgaria",
currency == "Czech koruna" ~ "Czechia",
currency == "Danish krone" ~ "Denmark",
currency == "Hungarian forint" ~ "Hungary",
currency == "Polish zloty" ~ "Poland",
currency == "Romanian leu" ~ "Romania",
currency == "Swedish krona" ~ "Sweden"
)) %>%
filter(!is.na(country)) %>%
mutate(exchange_rate_2022 = as.numeric(exchange_rate_2022))
ppp_data <- read_excel("data/power_purchasing_parity_2decimals.xlsx") %>%
select(country = Country, ppp_2022 = `2022`)
ppp_adjusted <- left_join(ppp_data, exchange_rates, by = "country") %>%
mutate(ppp_2022_adjusted = if_else(
!is.na(exchange_rate_2022),
ppp_2022 / exchange_rate_2022,
ppp_2022
)) %>%
select(country, ppp_2022_adjusted)
hh_r_silc_2023_ppp <- left_join(hh_r_silc_2023, ppp_adjusted, by = "country") %>%
mutate(
income_disposable_eqi_ppp = income_disposable_eqi / ppp_2022_adjusted
) %>%
left_join(., regiony, by = c("country", "region"))
EU_MEDIAN_PPP <- wtd.quantile(hh_r_silc_2023_ppp$income_disposable_eqi_ppp,
hh_r_silc_2023_ppp$hh_cross_weight, 0.5)
EU_MEDIAN_60PCT <- EU_MEDIAN_PPP * 0.6
EU_MEDIAN_50PCT <- EU_MEDIAN_PPP * 0.5
EU_MEDIAN_70PCT <- EU_MEDIAN_PPP * 0.7
hh_r_silc_2023_arop <- hh_r_silc_2023_ppp %>%
mutate(
under_arop = income_disposable_eqi_ppp < EU_MEDIAN_60PCT,
under_eu_poverty = income_disposable_eqi_ppp < EU_MEDIAN_50PCT,
under_eu_70_boundary = income_disposable_eqi_ppp < EU_MEDIAN_70PCT,
r_country = if_else(country == "Czechia", "Česko", "zbytek EU")
)
eu_arop_2023b <- hh_r_silc_2023_arop %>%
group_by(r_country) %>%
summarise(
pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100,
pct_under_eu_poverty = wtd.mean(under_eu_poverty, hh_cross_weight, na.rm = TRUE) * 100
)
eu_arop_2023b %>%
arrange(pct_under_arop) %>%
knitr::kable(., digits = 2, col.names = c("Country", "% under EU AROP", "% under 50% of EU median"))
| Country | % under EU AROP | % under 50% of EU median |
|---|---|---|
| zbytek EU | 19.25 | 12.82 |
| Česko | 21.68 | 10.35 |
eu_arop_2023 <- hh_r_silc_2023_arop %>%
group_by(country) %>%
summarise(
pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100,
pct_under_eu_poverty = wtd.mean(under_eu_poverty, hh_cross_weight, na.rm = TRUE) * 100)
eu_arop_2023 %>%
arrange(pct_under_arop) %>%
knitr::kable(., digits = 2, col.names = c("Country", "% under EU AROP", "% under 50% of EU median"))
| Country | % under EU AROP | % under 50% of EU median |
|---|---|---|
| Luxembourg | 3.12 | 2.38 |
| Belgium | 3.96 | 2.10 |
| Ireland | 4.73 | 2.40 |
| Austria | 6.43 | 4.10 |
| Denmark | 7.45 | 4.35 |
| Netherlands | 7.49 | 4.98 |
| Finland | 10.35 | 4.93 |
| Germany | 10.84 | 6.51 |
| France | 11.14 | 6.61 |
| Cyprus | 13.87 | 5.85 |
| Slovenia | 14.79 | 7.12 |
| Sweden | 15.21 | 9.71 |
| Malta | 17.39 | 9.63 |
| Italy | 17.92 | 11.75 |
| Spain | 20.14 | 12.79 |
| Czechia | 21.68 | 10.35 |
| Poland | 26.87 | 16.66 |
| Portugal | 37.70 | 25.59 |
| Estonia | 39.24 | 30.21 |
| Lithuania | 41.26 | 30.83 |
| Croatia | 42.35 | 31.80 |
| Latvia | 46.01 | 37.06 |
| Greece | 48.06 | 34.05 |
| Slovakia | 51.33 | 30.90 |
| Romania | 51.73 | 38.96 |
| Hungary | 55.85 | 42.35 |
| Bulgaria | 59.87 | 49.22 |
hh_r_silc_2023_arop |>
summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100)
## # A tibble: 1 × 1
## pct_under_arop
## <dbl>
## 1 19.3
national_medians <- hh_r_silc_2023_ppp %>%
group_by(country) %>%
summarise(median_income = wtd.quantile(income_disposable_eqi_ppp,
hh_cross_weight, 0.5),
.groups = "drop") %>%
mutate(
national_70_boundary = median_income * 0.7,
national_arop_boundary = median_income * 0.6,
national_poverty_boundary = median_income * 0.5
)
hh_r_silc_2023_national_arop <- full_join(hh_r_silc_2023_arop, national_medians,
by = "country") %>%
mutate(
under_70_boundary = income_disposable_eqi_ppp < national_70_boundary,
under_national_arop = income_disposable_eqi_ppp < national_arop_boundary,
under_national_poverty = income_disposable_eqi_ppp < national_poverty_boundary,
r_country = if_else(country == "Czechia", "Czechia", "Rest of EU")
)
eu_national_arop <- hh_r_silc_2023_national_arop %>%
group_by(r_country) %>%
summarise(pct_under_national_arop = wtd.mean(
under_national_arop, hh_cross_weight, na.rm = TRUE) * 100) %>%
left_join(eu_arop_2023b, ., by = "r_country")
eu_national_arop %>%
arrange(pct_under_national_arop) %>%
knitr::kable(., digits = 2, col.names = c("Country", "% under EU AROP", "% under 50% of EU median",
"% under national AROP"))
| Country | % under EU AROP | % under 50% of EU median | % under national AROP |
|---|---|---|---|
| zbytek EU | 19.25 | 12.82 | NA |
| Česko | 21.68 | 10.35 | NA |
eu_national_arop <- hh_r_silc_2023_national_arop %>%
group_by(country) %>%
summarise(pct_under_national_arop = wtd.mean(
under_national_arop, hh_cross_weight, na.rm = TRUE) * 100) %>%
left_join(eu_arop_2023, ., by = "country")
eu_national_arop %>%
arrange(pct_under_national_arop) %>%
knitr::kable(., digits = 2, col.names = c("Country", "% under EU AROP", "% under 50% of EU median",
"% under national AROP"))
| Country | % under EU AROP | % under 50% of EU median | % under national AROP |
|---|---|---|---|
| Czechia | 21.68 | 10.35 | 9.80 |
| Belgium | 3.96 | 2.10 | 10.20 |
| Finland | 10.35 | 4.93 | 12.69 |
| Hungary | 55.85 | 42.35 | 12.80 |
| Denmark | 7.45 | 4.35 | 12.83 |
| Slovakia | 51.33 | 30.90 | 13.29 |
| Netherlands | 7.49 | 4.98 | 14.56 |
| Ireland | 4.73 | 2.40 | 14.82 |
| France | 11.14 | 6.61 | 14.87 |
| Cyprus | 13.87 | 5.85 | 15.04 |
| Slovenia | 14.79 | 7.12 | 15.06 |
| Poland | 26.87 | 16.66 | 15.24 |
| Austria | 6.43 | 4.10 | 15.49 |
| Germany | 10.84 | 6.51 | 15.59 |
| Bulgaria | 59.87 | 49.22 | 16.24 |
| Sweden | 15.21 | 9.71 | 16.31 |
| Portugal | 37.70 | 25.59 | 17.47 |
| Luxembourg | 3.12 | 2.38 | 18.18 |
| Greece | 48.06 | 34.05 | 18.58 |
| Italy | 17.92 | 11.75 | 19.23 |
| Romania | 51.73 | 38.96 | 19.40 |
| Malta | 17.39 | 9.63 | 19.40 |
| Spain | 20.14 | 12.79 | 20.19 |
| Lithuania | 41.26 | 30.83 | 21.92 |
| Croatia | 42.35 | 31.80 | 22.30 |
| Latvia | 46.01 | 37.06 | 24.52 |
| Estonia | 39.24 | 30.21 | 25.58 |
ggplot(eu_national_arop, aes(x = pct_under_national_arop, y = pct_under_arop)) +
geom_point() +
geom_text_repel(aes(label = country)) +
scale_y_continuous(labels = scales::label_percent(scale = 1)) +
scale_x_continuous(labels = scales::label_percent(scale = 1)) +
geom_smooth(se = FALSE, method = "lm") +
theme_paq() +
labs(x = "% under (national) AROP", y = "% under EU AROP")
country_median_income_ppp <- hh_r_silc_2023_national_arop %>%
group_by(country) %>%
summarise(median_income_ppp = median(income_disposable_eqi_ppp)) %>%
arrange(desc(median_income_ppp))
hh_r_silc_2023_national_arop %>%
ggplot(aes(x = factor(country, levels = rev(country_median_income_ppp$country)),
y = income_disposable_eqi_ppp)) +
geom_boxplot(outliers = FALSE) +
geom_point(data = national_medians, aes(x = country, y = national_arop_boundary),
colour = "blue", shape = 3) +
geom_hline(yintercept = EU_MEDIAN_60PCT, colour = "red") +
theme_paq() +
coord_flip() +
labs(x = "", y = "Disponibilní ekvivalizovaný příjem domácnosti v PPS",
caption = "Modrý kříž indikuje národní hranici chudoby (60 % národního mediánu)")
chart_data <- hh_r_silc_2023_national_arop %>%
group_by(country) %>%
summarise(q90 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.90),
q10 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.10)) %>%
ungroup %>%
left_join(., national_medians, by = "country") %>%
mutate(country = factor(country, levels = rev(country_median_income_ppp$country)))
chart_data %>%
ggplot() +
geom_rect(aes(xmin = as.numeric(country) - 0.4,
xmax = as.numeric(country) + 0.4,
ymin = q10, ymax = q90),
alpha = 0.5) +
scale_x_continuous(
breaks = 1:nlevels(chart_data$country),
labels = levels(chart_data$country)
) +
scale_y_continuous(limits = c(0, NA)) +
geom_rect(aes(xmin = as.numeric(country) - 0.4,
xmax = as.numeric(country) + 0.4,
ymin = national_arop_boundary,
ymax = national_arop_boundary),
colour = "blue") +
geom_hline(yintercept = EU_MEDIAN_60PCT, colour = "red") +
coord_flip() +
theme_paq() +
labs(x = "", y = "Disponibilní ekvivalizovaný příjem domácnosti v PPS")
chart_data <- hh_r_silc_2023_national_arop %>%
group_by(country) %>%
summarise(q50 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.50),
q01 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.01)) %>%
ungroup %>%
left_join(., national_medians, by = "country") %>%
mutate(country = factor(country, levels = rev(country_median_income_ppp$country)))
chart_data %>%
ggplot() +
geom_rect(aes(xmin = as.numeric(country) - 0.4,
xmax = as.numeric(country) + 0.4,
ymin = q01, ymax = q50),
alpha = 0.5) +
scale_x_continuous(
breaks = 1:nlevels(chart_data$country),
labels = levels(chart_data$country)
) +
geom_rect(aes(xmin = as.numeric(country) - 0.4,
xmax = as.numeric(country) + 0.4,
ymin = national_arop_boundary,
ymax = national_arop_boundary),
colour = "blue") +
geom_hline(yintercept = EU_MEDIAN_60PCT, colour = "red") +
coord_flip() +
theme_paq() +
labs(x = "", y = "Disponibilní ekvivalizovaný příjem domácnosti v PPS")
chart_data_1_99 <- hh_r_silc_2023_national_arop %>%
group_by(country) %>%
summarise(q99 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.99),
q01 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.01)) %>%
ungroup %>%
left_join(., national_medians, by = "country") %>%
mutate(country = factor(country, levels = rev(country_median_income_ppp$country)))
chart_data_1_99 %>%
ggplot() +
geom_rect(aes(xmin = as.numeric(country) - 0.4,
xmax = as.numeric(country) + 0.4,
ymin = q01, ymax = q99),
alpha = 0.5) +
scale_x_continuous(
breaks = 1:nlevels(chart_data$country),
labels = levels(chart_data$country)
) +
geom_rect(aes(xmin = as.numeric(country) - 0.4,
xmax = as.numeric(country) + 0.4,
ymin = national_arop_boundary,
ymax = national_arop_boundary),
colour = "blue") +
geom_hline(yintercept = EU_MEDIAN_60PCT, colour = "red") +
coord_flip() +
theme_paq() +
labs(x = "", y = "Disponibilní ekvivalizovaný příjem domácnosti v PPS")
hh_r_silc_2023_national_arop %>%
filter(country == "Czechia") %>%
pull (income_disposable_eqi_ppp) %>%
density() -> m_dens
country_q95 <- hh_r_silc_2023_national_arop %>%
group_by(country) %>%
summarise(q95 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.95))
countries <- unique(hh_r_silc_2023_national_arop$country)
density_df <- purrr::map_df(countries, function(x) {
country <- x
tmp <- hh_r_silc_2023_national_arop %>%
filter(country == x)
national_arop_boundary <- unique(tmp$national_arop_boundary)
dens <- density(tmp$income_disposable_eqi_ppp, n = 50000)
tibble(
x = dens$x,
y = dens$y,
under_national_arop = x < national_arop_boundary,
country = country
)
})
CZ_MEDIAN_60PCT <- national_medians |>
filter(country == "Czechia") |>
pull(national_arop_boundary)
density_df %>%
left_join(., country_q95, by = "country") %>%
filter(x <= q95) %>%
mutate(
country = fct_case_when(
country == "Bulgaria" ~ "Bulharsko",
country == "Hungary" ~ "Maďarsko",
country == "Slovakia" ~ "Slovensko",
country == "Greece" ~ "Řecko",
country == "Romania" ~ "Rumunsko",
country == "Croatia" ~ "Chorvatsko",
country == "Latvia" ~ "Lotyšsko",
country == "Lithuania" ~ "Litva",
country == "Portugal" ~ "Portugalsko",
country == "Estonia" ~ "Estonsko",
country == "Poland" ~ "Polsko",
country == "Czechia" ~ "Česko",
country == "Malta" ~ "Malta",
country == "Cyprus" ~ "Kypr",
country == "Spain" ~ "Španělsko",
country == "Slovenia" ~ "Slovinsko",
country == "Italy" ~ "Itálie",
country == "France" ~ "Francie",
country == "Germany" ~ "Německo",
country == "Sweden" ~ "Švédsko",
country == "Denmark" ~ "Dánsko",
country == "Belgium" ~ "Belgie",
country == "Netherlands" ~ "Nizozemsko",
country == "Finland" ~ "Finsko",
country == "Ireland" ~ "Irsko",
country == "Austria" ~ "Rakousko",
country == "Luxembourg" ~ "Lucembursko"
),
under_national_arop = factor(under_national_arop,
levels = c(TRUE, FALSE),
labels = c("Pod 60 % mediánu národního příjmu",
"Nad 60 % mediánu"))
) %>%
ggplot(., aes(x = x, y = country,
height = y * 10000, fill = under_national_arop)) +
# geom_vline(xintercept = EU_MEDIAN_60PCT, colour = "red") +
# geom_vline(xintercept = EU_MEDIAN_50PCT, colour = "darkred") +
# geom_vline(xintercept = CZ_MEDIAN_60PCT, colour = "blue") +
geom_ridgeline_gradient() +
scale_x_continuous(limits = c(0, 75000), labels = scales::comma_format(big.mark = " ")) +
scale_fill_manual(values = c("Pod 60 % mediánu národního příjmu" = "#ECB925",
"Nad 60 % mediánu" = "gray80")) +
theme_paq() +
# theme(legend.position = "none") +
labs(x = "Ekvivalizovaný příjem domácnosti ve standardu kupní síly", y = ""
# caption = "Distribuce nezobrazují hodnoty nad 95. percentil v daném státu. Modrá svislice ukazuje českou hranici chudoby,\ntmavě červená 50 % evropského mediánu, červená evropskou hranici chudoby (60 % mediánu)."
)
save_plot(plot = last_plot(),
path = "figs/arop/arop1.png",
height_px = 600,
width_px = 600)
hh_r_silc_2023_national_arop |>
group_by(country) |>
mutate(under_cz_arop = income_disposable_eqi_ppp < CZ_MEDIAN_60PCT) |>
summarise(under_cz_arop = wtd.mean(under_cz_arop, hh_cross_weight, na.rm = TRUE) * 100) |>
arrange(under_cz_arop) |>
knitr::kable(col.names = c("Country", "% under CZ poverty line"))
| Country | % under CZ poverty line |
|---|---|
| Belgium | 2.045642 |
| Ireland | 2.254960 |
| Luxembourg | 2.377036 |
| Austria | 4.031356 |
| Denmark | 4.149577 |
| Finland | 4.593589 |
| Netherlands | 4.946518 |
| Cyprus | 5.458738 |
| Germany | 6.268019 |
| France | 6.385330 |
| Slovenia | 6.921078 |
| Malta | 9.326997 |
| Sweden | 9.475918 |
| Czechia | 9.803617 |
| Italy | 11.274460 |
| Spain | 12.459903 |
| Poland | 16.022737 |
| Portugal | 24.701623 |
| Slovakia | 29.314007 |
| Estonia | 29.366123 |
| Lithuania | 30.124821 |
| Croatia | 31.054021 |
| Greece | 32.842150 |
| Latvia | 36.504372 |
| Romania | 37.551559 |
| Hungary | 41.150338 |
| Bulgaria | 48.173245 |
AROPE = (AROP | nízká pracovní intenzita | vážná materiální nebo sociální deprivace)
hh_r_silc_2023_national_arop %>%
group_by(country) %>%
summarise(
severely_deprived = wtd.mean(severe_material_social_deprivation, hh_cross_weight)
)
## # A tibble: 27 × 2
## country severely_deprived
## <chr> <dbl>
## 1 Austria 0.0407
## 2 Belgium 0.0703
## 3 Bulgaria 0.192
## 4 Croatia 0.0422
## 5 Cyprus 0.0299
## 6 Czechia 0.0283
## 7 Denmark 0.0600
## 8 Estonia 0.0277
## 9 Finland 0.0385
## 10 France 0.0713
## # ℹ 17 more rows
hh_r_silc_2023_national_arop %>%
filter(low_work_intensity != 2) %>%
group_by(country) %>%
summarise(
low_work_intensity = wtd.mean(low_work_intensity, hh_cross_weight)
)
## # A tibble: 27 × 2
## country low_work_intensity
## <chr> <dbl>
## 1 Austria 0.0752
## 2 Belgium 0.139
## 3 Bulgaria 0.0757
## 4 Croatia 0.0506
## 5 Cyprus 0.0533
## 6 Czechia 0.0553
## 7 Denmark 0.150
## 8 Estonia 0.0786
## 9 Finland 0.124
## 10 France 0.104
## # ℹ 17 more rows
hh_r_silc_2023_national_arop %>%
mutate(arope = under_national_arop |
low_work_intensity == 1 |
severe_material_social_deprivation == 1) %>%
group_by(country) %>%
summarise(
pct_arope = wtd.mean(arope, hh_cross_weight),
pct_national_arop = wtd.mean(under_national_arop, hh_cross_weight)
) %>%
ggplot(., aes(x = pct_arope, y = pct_national_arop)) +
# geom_abline(slope = 1, colour = "black") +
geom_smooth(method = "lm", se = FALSE, colour = "gray80") +
geom_text_repel(aes(label = country)) +
geom_point() +
scale_x_continuous(labels = scales::label_percent(suffix = " %")) +
scale_y_continuous(labels = scales::label_percent(suffix = " %")) +
theme_paq() +
coord_equal() +
labs(x = "Podíl domácností v ohrožení chudobou a sociálním vyloučením",
y = "Podíl domácností v ohrožení chudobou")
hh_r_silc_2023_national_arop |>
ggplot(aes(x = sum_deprived_items)) +
geom_histogram(aes(y = ..density..), bins = 14) +
facet_wrap(~country) +
theme_paq()
aropes <- hh_r_silc_2023_national_arop %>%
mutate(arope = under_national_arop |
low_work_intensity == 1 |
severe_material_social_deprivation == 1,
eu_arope = under_eu_poverty |
low_work_intensity == 1 |
severe_material_social_deprivation == 1) %>%
group_by(country) %>%
summarise(
pct_eu_arope = wtd.mean(eu_arope, hh_cross_weight),
pct_national_arope = wtd.mean(arope, hh_cross_weight)
) %>%
mutate(
country = fct_case_when(
country == "Bulgaria" ~ "Bulharsko",
country == "Hungary" ~ "Maďarsko",
country == "Slovakia" ~ "Slovensko",
country == "Greece" ~ "Řecko",
country == "Romania" ~ "Rumunsko",
country == "Croatia" ~ "Chorvatsko",
country == "Latvia" ~ "Lotyšsko",
country == "Lithuania" ~ "Litva",
country == "Portugal" ~ "Portugalsko",
country == "Estonia" ~ "Estonsko",
country == "Poland" ~ "Polsko",
country == "Czechia" ~ "Česko",
country == "Malta" ~ "Malta",
country == "Cyprus" ~ "Kypr",
country == "Spain" ~ "Španělsko",
country == "Slovenia" ~ "Slovinsko",
country == "Italy" ~ "Itálie",
country == "France" ~ "Francie",
country == "Germany" ~ "Německo",
country == "Sweden" ~ "Švédsko",
country == "Denmark" ~ "Dánsko",
country == "Belgium" ~ "Belgie",
country == "Netherlands" ~ "Nizozemsko",
country == "Finland" ~ "Finsko",
country == "Ireland" ~ "Irsko",
country == "Austria" ~ "Rakousko",
country == "Luxembourg" ~ "Lucembursko"
)
)
aropes %>%
ggplot(., aes(x = pct_eu_arope, y = pct_national_arope)) +
geom_smooth(method = "lm", se = FALSE, colour = "gray80") +
geom_text_repel(aes(label = country)) +
geom_point() +
scale_x_continuous(labels = scales::label_percent(suffix = " %")) +
scale_y_continuous(labels = scales::label_percent(suffix = " %")) +
theme_paq() +
coord_equal() +
labs(x = "Podíl domácností v ohrožení EU chudobou (50 % evropského mediánu) a sociálním vyloučením",
y = "Podíl domácností v ohrožení národní chudobou (60 % národního mediánu) a sociálním vyloučením")
cntry_levels <- aropes |> arrange(pct_eu_arope) |> pull(country)
aropes %>%
tidyr::pivot_longer(cols = c(pct_eu_arope, pct_national_arope)) %>%
mutate(name = case_when(
name == "pct_eu_arope" ~ "Podíl domácností v ohrožení EU chudobou (50 % evropského mediánu) a sociálním vyloučením",
name == "pct_national_arope" ~ "Podíl domácností v ohrožení národní chudobou (60 % národního mediánu) a sociálním vyloučením"
),
country = factor(country, levels = rev(cntry_levels))
) %>%
ggplot(., aes(x = country, y = value, fill = name)) +
geom_bar(stat = "identity", position = "dodge") +
scale_y_continuous(labels = scales::label_percent(suffix = " %")) +
coord_flip() +
theme_paq() +
guides(fill = guide_legend(nrow = 2)) +
scale_fill_manual(values = paleta_kategoricka(2)) +
labs(x = "", y = "")
save_plot(plot = last_plot(),
path = "figs/arop/aropes.png",
height_px = 600,
width_px = 600)
national_arope_data <- hh_r_silc_2023_national_arop |>
mutate(type = fct_case_when(
under_national_arop ~ "Pod národní hranicí chudoby",
severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
low_work_intensity == 1 ~ "Nízká pracovní intenzita",
TRUE ~ "není v AROPE",
new_levels = c("není v AROPE", "Nízká pracovní intenzita", "Vážně materiálně či sociálně deprivovaný", "Pod národní hranicí chudoby")
),
country = fct_case_when(
country == "Bulgaria" ~ "Bulharsko",
country == "Hungary" ~ "Maďarsko",
country == "Slovakia" ~ "Slovensko",
country == "Greece" ~ "Řecko",
country == "Romania" ~ "Rumunsko",
country == "Croatia" ~ "Chorvatsko",
country == "Latvia" ~ "Lotyšsko",
country == "Lithuania" ~ "Litva",
country == "Portugal" ~ "Portugalsko",
country == "Estonia" ~ "Estonsko",
country == "Poland" ~ "Polsko",
country == "Czechia" ~ "Česko",
country == "Malta" ~ "Malta",
country == "Cyprus" ~ "Kypr",
country == "Spain" ~ "Španělsko",
country == "Slovenia" ~ "Slovinsko",
country == "Italy" ~ "Itálie",
country == "France" ~ "Francie",
country == "Germany" ~ "Německo",
country == "Sweden" ~ "Švédsko",
country == "Denmark" ~ "Dánsko",
country == "Belgium" ~ "Belgie",
country == "Netherlands" ~ "Nizozemsko",
country == "Finland" ~ "Finsko",
country == "Ireland" ~ "Irsko",
country == "Austria" ~ "Rakousko",
country == "Luxembourg" ~ "Lucembursko"
)
)
eu_arope_split <- national_arope_data |>
group_by(type) |>
summarise(n = sum(hh_cross_weight)) |>
ungroup() |>
mutate(pct = n / sum(n),
country = "EU")
arope_split <- national_arope_data |>
group_by(country, type) |>
summarise(n = sum(hh_cross_weight)) |>
group_by(country) |>
mutate(pct = n / sum(n))
arope_split_countries <- arope_split |>
filter(type == "není v AROPE") |>
arrange(desc(pct)) |>
pull(country)
arope_split |>
filter(type != "není v AROPE") |>
mutate(country = factor(country, levels = arope_split_countries)) |>
ggplot(aes(x = country, y = pct, fill = type)) +
geom_bar(stat = "identity") +
theme_paq() +
scale_y_continuous(labels = scales::label_percent(suffix = " %"), expand = c(0, 0)) +
scale_fill_manual(values = paleta_kategoricka(3)) +
coord_flip() +
labs(x = "", y = "% domácností") +
guides(fill = guide_legend(nrow = 3, reverse = TRUE)) +
theme(panel.grid.major.y = element_blank())
save_plot(last_plot(), "figs/arop/arop_composition.png")
arope_split |>
bind_rows(eu_arope_split) |>
filter(type != "není v AROPE") |>
mutate(country = factor(country, levels = c(as.character(arope_split_countries), "EU"))) |>
ggplot(aes(x = country, y = pct, fill = type)) +
geom_bar(stat = "identity") +
theme_paq() +
scale_y_continuous(labels = scales::label_percent(suffix = " %"), expand = c(0, 0)) +
scale_fill_manual(values = rev(paleta_kategoricka(3))) +
coord_flip() +
labs(x = "", y = "% domácností") +
guides(fill = guide_legend(nrow = 3, reverse = TRUE))
save_plot(last_plot(), "figs/arop/arop_composition_w_eu.png")
heatmap_data <- hh_r_silc_2023_national_arop |>
mutate(
national_arop = fct_case_when(
under_national_arop ~ "Pod národní hranicí chudoby",
TRUE ~ "Nad národní hranicí chudoby"
),
deprivation = fct_case_when(
severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
TRUE ~ "Není vážně deprivovaný"
),
work_intensity = fct_case_when(
low_work_intensity == 1 ~ "Nízká pracovní intenzita",
low_work_intensity != 1 ~ "Dostatečná pracovní intenzita"
),
country = fct_case_when(
country == "Bulgaria" ~ "Bulharsko",
country == "Hungary" ~ "Maďarsko",
country == "Slovakia" ~ "Slovensko",
country == "Greece" ~ "Řecko",
country == "Romania" ~ "Rumunsko",
country == "Croatia" ~ "Chorvatsko",
country == "Latvia" ~ "Lotyšsko",
country == "Lithuania" ~ "Litva",
country == "Portugal" ~ "Portugalsko",
country == "Estonia" ~ "Estonsko",
country == "Poland" ~ "Polsko",
country == "Czechia" ~ "Česko",
country == "Malta" ~ "Malta",
country == "Cyprus" ~ "Kypr",
country == "Spain" ~ "Španělsko",
country == "Slovenia" ~ "Slovinsko",
country == "Italy" ~ "Itálie",
country == "France" ~ "Francie",
country == "Germany" ~ "Německo",
country == "Sweden" ~ "Švédsko",
country == "Denmark" ~ "Dánsko",
country == "Belgium" ~ "Belgie",
country == "Netherlands" ~ "Nizozemsko",
country == "Finland" ~ "Finsko",
country == "Ireland" ~ "Irsko",
country == "Austria" ~ "Rakousko",
country == "Luxembourg" ~ "Lucembursko"
)
) |>
group_by(country, national_arop, deprivation, work_intensity) |>
summarise(n = sum(hh_cross_weight)) |>
group_by(country) |>
mutate(pct = n / sum(n))
heatmap_data |>
filter(!(deprivation == "Není vážně deprivovaný" & national_arop == "Nad národní hranicí chudoby" & work_intensity == "Dostatečná pracovní intenzita")) |>
ggplot(aes(x = work_intensity, y = country, fill = pct)) +
geom_tile() +
facet_wrap(deprivation ~ national_arop)
library(ggupset)
upset_chart_data <- hh_r_silc_2023_national_arop |>
mutate(
national_arop = case_when(
under_national_arop ~ "Pod národní hranicí chudoby",
TRUE ~ NA
),
deprivation = case_when(
severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
TRUE ~ NA
),
work_intensity = case_when(
low_work_intensity == 1 ~ "Nízká pracovní intenzita",
low_work_intensity != 1 ~ NA
),
country = fct_case_when(
country == "Bulgaria" ~ "Bulharsko",
country == "Hungary" ~ "Maďarsko",
country == "Slovakia" ~ "Slovensko",
country == "Greece" ~ "Řecko",
country == "Romania" ~ "Rumunsko",
country == "Croatia" ~ "Chorvatsko",
country == "Latvia" ~ "Lotyšsko",
country == "Lithuania" ~ "Litva",
country == "Portugal" ~ "Portugalsko",
country == "Estonia" ~ "Estonsko",
country == "Poland" ~ "Polsko",
country == "Czechia" ~ "Česko",
country == "Malta" ~ "Malta",
country == "Cyprus" ~ "Kypr",
country == "Spain" ~ "Španělsko",
country == "Slovenia" ~ "Slovinsko",
country == "Italy" ~ "Itálie",
country == "France" ~ "Francie",
country == "Germany" ~ "Německo",
country == "Sweden" ~ "Švédsko",
country == "Denmark" ~ "Dánsko",
country == "Belgium" ~ "Belgie",
country == "Netherlands" ~ "Nizozemsko",
country == "Finland" ~ "Finsko",
country == "Ireland" ~ "Irsko",
country == "Austria" ~ "Rakousko",
country == "Luxembourg" ~ "Lucembursko"
)
) |>
select(hh_id, country, hh_cross_weight, national_arop, deprivation, work_intensity) |>
tidyr::pivot_longer(cols = c(national_arop, deprivation, work_intensity)) |>
group_by(hh_id, country) |>
summarise(
characteristics = list(value), .groups = "drop",
hh_cross_weight = unique(hh_cross_weight)
) |>
group_by(country, characteristics) |>
summarise(n = sum(hh_cross_weight), .groups = "drop") |>
group_by(country) |>
mutate(
pct = n / sum(n),
n_nas = purrr::map_int(characteristics, ~sum(is.na(.x)))
) |>
# filter(country == "Česko") |>
filter(n_nas != 3)
upset_chart_data |>
filter(country == "Česko") |>
ggplot(aes(x = characteristics, y = pct)) +
geom_bar(stat = "identity") +
scale_x_upset() +
scale_y_continuous(labels = scales::label_percent(suffix = " %")) +
labs(x = "", y = "% domácností") +
theme_paq() +
theme(plot.margin = margin(2, 2, 2, 150))
upset_chart_data |>
ggplot(aes(x = characteristics, y = pct)) +
geom_bar(stat = "identity") +
scale_x_upset() +
scale_y_continuous(labels = scales::label_percent(suffix = " %"), limits = c(0, 0.21)) +
facet_wrap(~country, ncol = 5) +
theme_paq()
create_euler_data <- function(df, cntry){
c(
"Pod hranicí chudoby" = df |>
filter(country == !!cntry) |>
filter(national_arop == "Pod národní hranicí chudoby",
work_intensity == "Dostatečná pracovní intenzita",
deprivation == "Není vážně deprivovaný") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Nízká pracovní\nintenzita" = df |>
filter(country == !!cntry) |>
filter(work_intensity == "Nízká pracovní intenzita",
deprivation == "Není vážně deprivovaný",
national_arop == "Nad národní hranicí chudoby") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Vážná materiální\nči sociální deprivace" = df |>
filter(country == !!cntry) |>
filter(deprivation == "Vážně materiálně či sociálně deprivovaný",
work_intensity == "Nízká pracovní intenzita",
national_arop == "Nad národní hranicí chudoby") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Pod hranicí chudoby&Nízká pracovní\nintenzita" = df |>
filter(country == !!cntry) |>
filter(national_arop == "Pod národní hranicí chudoby",
work_intensity == "Nízká pracovní intenzita") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Pod hranicí chudoby&Vážná materiální\nči sociální deprivace" = df |>
filter(country == !!cntry) |>
filter(national_arop == "Pod národní hranicí chudoby",
deprivation == "Vážně materiálně či sociálně deprivovaný") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = df |>
filter(country == !!cntry) |>
filter(work_intensity == "Nízká pracovní intenzita",
deprivation == "Vážně materiálně či sociálně deprivovaný") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Pod hranicí chudoby&Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = df |>
filter(country == !!cntry) |>
filter(work_intensity == "Nízká pracovní intenzita",
deprivation == "Vážně materiálně či sociálně deprivovaný",
national_arop == "Pod národní hranicí chudoby") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct)
)
}
countries <- unique(heatmap_data$country)
euler_charts <- purrr::map(countries, function(x) {
euler_df <- create_euler_data(heatmap_data, x)
fit <-euler(euler_df, shape = "ellipse")
plot(fit, quantities = TRUE, main = as.character(x), labels = FALSE)
})
euler_mega_chart <- gridExtra::grid.arrange(
euler_charts[[1]], euler_charts[[2]], euler_charts[[3]],
euler_charts[[4]], euler_charts[[5]],
euler_charts[[6]], euler_charts[[7]], euler_charts[[8]],
euler_charts[[9]], euler_charts[[10]],
euler_charts[[11]], euler_charts[[12]], euler_charts[[13]],
euler_charts[[14]], euler_charts[[15]],
euler_charts[[16]], euler_charts[[17]], euler_charts[[18]],
euler_charts[[19]], euler_charts[[20]],
euler_charts[[21]], euler_charts[[22]], euler_charts[[23]],
euler_charts[[24]], euler_charts[[25]],
euler_charts[[26]], euler_charts[[27]],
ncol = 5
)
save_plot(euler_mega_chart, "figs/arop/euler_diagrams.png", width_px = 1000, height_px = 1000)
all_countries_heatmap_data <- hh_r_silc_2023_national_arop |>
mutate(
national_arop = fct_case_when(
under_national_arop ~ "Pod národní hranicí chudoby",
TRUE ~ "Nad národní hranicí chudoby"
),
deprivation = fct_case_when(
severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
TRUE ~ "Není vážně deprivovaný"
),
work_intensity = fct_case_when(
low_work_intensity == 1 ~ "Nízká pracovní intenzita",
low_work_intensity != 1 ~ "Dostatečná pracovní intenzita"
)
) |>
group_by(national_arop, deprivation, work_intensity) |>
summarise(n = sum(hh_cross_weight)) |> ungroup() |>
mutate(pct = n / sum(n))
eu_euler <-
c(
"Pod hranicí chudoby" = all_countries_heatmap_data |> ungroup() |>
filter(national_arop == "Pod národní hranicí chudoby",
work_intensity == "Dostatečná pracovní intenzita",
deprivation == "Není vážně deprivovaný") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Nízká pracovní\nintenzita" = all_countries_heatmap_data |> ungroup() |>
filter(work_intensity == "Nízká pracovní intenzita",
deprivation == "Není vážně deprivovaný",
national_arop == "Nad národní hranicí chudoby") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Vážná materiální\nči sociální deprivace" = all_countries_heatmap_data |> ungroup() |>
filter(deprivation == "Vážně materiálně či sociálně deprivovaný",
work_intensity == "Nízká pracovní intenzita",
national_arop == "Nad národní hranicí chudoby") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Pod hranicí chudoby&Nízká pracovní\nintenzita" = all_countries_heatmap_data |> ungroup() |>
filter(national_arop == "Pod národní hranicí chudoby",
work_intensity == "Nízká pracovní intenzita") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Pod hranicí chudoby&Vážná materiální\nči sociální deprivace" = all_countries_heatmap_data |> ungroup() |>
filter(national_arop == "Pod národní hranicí chudoby",
deprivation == "Vážně materiálně či sociálně deprivovaný") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = all_countries_heatmap_data |> ungroup() |>
filter(work_intensity == "Nízká pracovní intenzita",
deprivation == "Vážně materiálně či sociálně deprivovaný") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Pod hranicí chudoby&Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = all_countries_heatmap_data |> ungroup() |>
filter(work_intensity == "Nízká pracovní intenzita",
deprivation == "Vážně materiálně či sociálně deprivovaný",
national_arop == "Pod národní hranicí chudoby") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct)
)
eu_fit <- euler(eu_euler, shape = "ellipse")
arope_split2_data <- hh_r_silc_2023_national_arop |>
mutate(type = fct_case_when(
under_arop ~ "Pod evropskou hranicí chudoby",
severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
low_work_intensity == 1 ~ "Nízká pracovní intenzita",
TRUE ~ "není v AROPE",
new_levels = c("není v AROPE", "Nízká pracovní intenzita", "Vážně materiálně či sociálně deprivovaný", "Pod evropskou hranicí chudoby")
),
country = fct_case_when(
country == "Bulgaria" ~ "Bulharsko",
country == "Hungary" ~ "Maďarsko",
country == "Slovakia" ~ "Slovensko",
country == "Greece" ~ "Řecko",
country == "Romania" ~ "Rumunsko",
country == "Croatia" ~ "Chorvatsko",
country == "Latvia" ~ "Lotyšsko",
country == "Lithuania" ~ "Litva",
country == "Portugal" ~ "Portugalsko",
country == "Estonia" ~ "Estonsko",
country == "Poland" ~ "Polsko",
country == "Czechia" ~ "Česko",
country == "Malta" ~ "Malta",
country == "Cyprus" ~ "Kypr",
country == "Spain" ~ "Španělsko",
country == "Slovenia" ~ "Slovinsko",
country == "Italy" ~ "Itálie",
country == "France" ~ "Francie",
country == "Germany" ~ "Německo",
country == "Sweden" ~ "Švédsko",
country == "Denmark" ~ "Dánsko",
country == "Belgium" ~ "Belgie",
country == "Netherlands" ~ "Nizozemsko",
country == "Finland" ~ "Finsko",
country == "Ireland" ~ "Irsko",
country == "Austria" ~ "Rakousko",
country == "Luxembourg" ~ "Lucembursko"
)
)
arope_split2 <- arope_split2_data |>
group_by(country, type) |>
summarise(n = sum(hh_cross_weight)) |>
group_by(country) |>
mutate(pct = n / sum(n))
eu_arope_split2 <- arope_split2_data |>
group_by(type) |>
summarise(n = sum(hh_cross_weight)) |>
ungroup() |>
mutate(pct = n / sum(n),
country = "EU")
arope_split_countries2 <- arope_split2 |>
filter(type == "není v AROPE") |>
arrange(desc(pct)) |>
pull(country)
arope_split2 |>
filter(type != "není v AROPE") |>
mutate(country = factor(country, levels = arope_split_countries2)) |>
ggplot(aes(x = country, y = pct, fill = type)) +
geom_bar(stat = "identity") +
theme_paq() +
scale_y_continuous(labels = scales::label_percent(suffix = " %"), expand = c(0, 0)) +
scale_fill_manual(values = rev(paleta_kategoricka(3))) +
coord_flip() +
labs(x = "", y = "% domácností") +
guides(fill = guide_legend(nrow = 3, reverse = TRUE))
save_plot(last_plot(), "figs/arop/eu_arop_composition.png")
arope_split2 |>
bind_rows(eu_arope_split2) |>
filter(type != "není v AROPE") |>
mutate(country = factor(country, levels = c(as.character(arope_split_countries2), "EU"))) |>
ggplot(aes(x = country, y = pct, fill = type)) +
geom_bar(stat = "identity") +
theme_paq() +
scale_y_continuous(labels = scales::label_percent(suffix = " %"), expand = c(0, 0)) +
scale_fill_manual(values = rev(paleta_kategoricka(3))) +
coord_flip() +
labs(x = "", y = "% domácností") +
guides(fill = guide_legend(nrow = 3, reverse = TRUE))
save_plot(last_plot(), "figs/arop/eu_arop_composition_w_eu.png")
eu_heatmap_data <- hh_r_silc_2023_national_arop |>
mutate(
eu_arop = fct_case_when(
under_arop ~ "Pod evropskou hranicí chudoby",
TRUE ~ "Nad evropskou hranicí chudoby"
),
deprivation = fct_case_when(
severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
TRUE ~ "Není vážně deprivovaný"
),
work_intensity = fct_case_when(
low_work_intensity == 1 ~ "Nízká pracovní intenzita",
low_work_intensity != 1 ~ "Dostatečná pracovní intenzita"
),
country = fct_case_when(
country == "Bulgaria" ~ "Bulharsko",
country == "Hungary" ~ "Maďarsko",
country == "Slovakia" ~ "Slovensko",
country == "Greece" ~ "Řecko",
country == "Romania" ~ "Rumunsko",
country == "Croatia" ~ "Chorvatsko",
country == "Latvia" ~ "Lotyšsko",
country == "Lithuania" ~ "Litva",
country == "Portugal" ~ "Portugalsko",
country == "Estonia" ~ "Estonsko",
country == "Poland" ~ "Polsko",
country == "Czechia" ~ "Česko",
country == "Malta" ~ "Malta",
country == "Cyprus" ~ "Kypr",
country == "Spain" ~ "Španělsko",
country == "Slovenia" ~ "Slovinsko",
country == "Italy" ~ "Itálie",
country == "France" ~ "Francie",
country == "Germany" ~ "Německo",
country == "Sweden" ~ "Švédsko",
country == "Denmark" ~ "Dánsko",
country == "Belgium" ~ "Belgie",
country == "Netherlands" ~ "Nizozemsko",
country == "Finland" ~ "Finsko",
country == "Ireland" ~ "Irsko",
country == "Austria" ~ "Rakousko",
country == "Luxembourg" ~ "Lucembursko"
)
) |>
group_by(country, eu_arop, deprivation, work_intensity) |>
summarise(n = sum(hh_cross_weight)) |>
group_by(country) |>
mutate(pct = n / sum(n))
create_eu_euler_data <- function(df, cntry){
c(
"Pod hranicí chudoby" = df |>
filter(country == !!cntry) |>
filter(eu_arop == "Pod evropskou hranicí chudoby",
work_intensity == "Dostatečná pracovní intenzita",
deprivation == "Není vážně deprivovaný") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Nízká pracovní\nintenzita" = df |>
filter(country == !!cntry) |>
filter(work_intensity == "Nízká pracovní intenzita",
eu_arop == "Nad evropskou hranicí chudoby",
deprivation == "Není vážně deprivovaný") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Vážná materiální\nči sociální deprivace" = df |>
filter(country == !!cntry) |>
filter(deprivation == "Vážně materiálně či sociálně deprivovaný",
eu_arop == "Nad evropskou hranicí chudoby",
work_intensity == "Dostatečná pracovní intenzita") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Pod hranicí chudoby&Nízká pracovní\nintenzita" = df |>
filter(country == !!cntry) |>
filter(eu_arop == "Pod evropskou hranicí chudoby",
work_intensity == "Nízká pracovní intenzita") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Pod hranicí chudoby&Vážná materiální\nči sociální deprivace" = df |>
filter(country == !!cntry) |>
filter(eu_arop == "Pod evropskou hranicí chudoby",
deprivation == "Vážně materiálně či sociálně deprivovaný") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = df |>
filter(country == !!cntry) |>
filter(work_intensity == "Nízká pracovní intenzita",
deprivation == "Vážně materiálně či sociálně deprivovaný") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Pod hranicí chudoby&Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = df |>
filter(country == !!cntry) |>
filter(work_intensity == "Nízká pracovní intenzita",
deprivation == "Vážně materiálně či sociálně deprivovaný",
eu_arop == "Pod evropskou hranicí chudoby") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct)
)
}
countries <- unique(eu_heatmap_data$country)
eu_euler_charts <- purrr::map(countries, function(x) {
euler_df <- create_eu_euler_data(eu_heatmap_data, x)
fit <-euler(euler_df, shape = "ellipse")
plot(fit, quantities = TRUE, main = as.character(x), labels = FALSE)
})
eu_euler_mega_chart <- gridExtra::grid.arrange(
eu_euler_charts[[1]], eu_euler_charts[[2]], eu_euler_charts[[3]],
eu_euler_charts[[4]], eu_euler_charts[[5]],
eu_euler_charts[[6]], eu_euler_charts[[7]], eu_euler_charts[[8]],
eu_euler_charts[[9]], eu_euler_charts[[10]],
eu_euler_charts[[11]], eu_euler_charts[[12]], eu_euler_charts[[13]],
eu_euler_charts[[14]], eu_euler_charts[[15]],
eu_euler_charts[[16]], eu_euler_charts[[17]], eu_euler_charts[[18]],
eu_euler_charts[[19]], eu_euler_charts[[20]],
eu_euler_charts[[21]], eu_euler_charts[[22]], eu_euler_charts[[23]],
eu_euler_charts[[24]], eu_euler_charts[[25]],
eu_euler_charts[[26]], eu_euler_charts[[27]],
ncol = 5
)
save_plot(eu_euler_mega_chart, "figs/arop/euler_eu_diagrams.png",
width_px = 1000, height_px = 1000)
all_countries_eu_heatmap_data <- hh_r_silc_2023_national_arop |>
mutate(
eu_arop = fct_case_when(
under_arop ~ "Pod evropskou hranicí chudoby",
TRUE ~ "Nad evropskou hranicí chudoby"
),
deprivation = fct_case_when(
severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
TRUE ~ "Není vážně deprivovaný"
),
work_intensity = fct_case_when(
low_work_intensity == 1 ~ "Nízká pracovní intenzita",
low_work_intensity != 1 ~ "Dostatečná pracovní intenzita"
)
) |>
group_by(eu_arop, deprivation, work_intensity) |>
summarise(n = sum(hh_cross_weight)) |> ungroup() |>
mutate(pct = n / sum(n))
all_countries_euler_df <- c(
"Pod EU hranicí chudoby" = all_countries_eu_heatmap_data |>
filter(eu_arop == "Pod evropskou hranicí chudoby",
work_intensity == "Dostatečná pracovní intenzita",
deprivation == "Není vážně deprivovaný") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Nízká pracovní\nintenzita" = all_countries_eu_heatmap_data |>
filter(work_intensity == "Nízká pracovní intenzita",
eu_arop == "Nad evropskou hranicí chudoby",
deprivation == "Není vážně deprivovaný") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Vážná materiální\nči sociální deprivace" = all_countries_eu_heatmap_data |>
filter(deprivation == "Vážně materiálně či sociálně deprivovaný",
eu_arop == "Nad evropskou hranicí chudoby",
work_intensity == "Dostatečná pracovní intenzita") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Pod EU hranicí chudoby&Nízká pracovní\nintenzita" = all_countries_eu_heatmap_data |>
filter(eu_arop == "Pod evropskou hranicí chudoby",
work_intensity == "Nízká pracovní intenzita") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Pod EU hranicí chudoby&Vážná materiální\nči sociální deprivace" = all_countries_eu_heatmap_data |>
filter(eu_arop == "Pod evropskou hranicí chudoby",
deprivation == "Vážně materiálně či sociálně deprivovaný") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = all_countries_eu_heatmap_data |>
filter(work_intensity == "Nízká pracovní intenzita",
deprivation == "Vážně materiálně či sociálně deprivovaný") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct),
"Pod EU hranicí chudoby&Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = all_countries_eu_heatmap_data |>
filter(work_intensity == "Nízká pracovní intenzita",
deprivation == "Vážně materiálně či sociálně deprivovaný",
eu_arop == "Pod evropskou hranicí chudoby") |>
summarise(pct = round(sum(pct) * 100, 1)) |>
pull(pct)
)
fit <-euler(all_countries_euler_df, shape = "ellipse")
plot(fit, quantities = TRUE, main = "EU", labels = TRUE)
aropes2 <- hh_r_silc_2023_national_arop %>%
mutate(arope = under_national_arop |
low_work_intensity == 1 |
sum_deprived_items_wo_expenses > 6,
eu_arope = under_eu_poverty |
low_work_intensity == 1 |
sum_deprived_items_wo_expenses > 6) %>%
group_by(country) %>%
summarise(
pct_eu_arope = wtd.mean(eu_arope, hh_cross_weight),
pct_national_arope = wtd.mean(arope, hh_cross_weight)
) %>%
mutate(
country = fct_case_when(
country == "Bulgaria" ~ "Bulharsko",
country == "Hungary" ~ "Maďarsko",
country == "Slovakia" ~ "Slovensko",
country == "Greece" ~ "Řecko",
country == "Romania" ~ "Rumunsko",
country == "Croatia" ~ "Chorvatsko",
country == "Latvia" ~ "Lotyšsko",
country == "Lithuania" ~ "Litva",
country == "Portugal" ~ "Portugalsko",
country == "Estonia" ~ "Estonsko",
country == "Poland" ~ "Polsko",
country == "Czechia" ~ "Česko",
country == "Malta" ~ "Malta",
country == "Cyprus" ~ "Kypr",
country == "Spain" ~ "Španělsko",
country == "Slovenia" ~ "Slovinsko",
country == "Italy" ~ "Itálie",
country == "France" ~ "Francie",
country == "Germany" ~ "Německo",
country == "Sweden" ~ "Švédsko",
country == "Denmark" ~ "Dánsko",
country == "Belgium" ~ "Belgie",
country == "Netherlands" ~ "Nizozemsko",
country == "Finland" ~ "Finsko",
country == "Ireland" ~ "Irsko",
country == "Austria" ~ "Rakousko",
country == "Luxembourg" ~ "Lucembursko"
)
)
aropes2 %>%
ggplot(., aes(x = pct_eu_arope, y = pct_national_arope)) +
geom_smooth(method = "lm", se = FALSE, colour = "gray80") +
geom_text_repel(aes(label = country)) +
geom_point() +
scale_x_continuous(labels = scales::label_percent(suffix = " %")) +
scale_y_continuous(labels = scales::label_percent(suffix = " %")) +
theme_paq() +
labs(x = "Podíl domácností v ohrožení EU chudobou (50 % evropského mediánu) a sociálním vyloučením",
y = "Podíl domácností v ohrožení národní chudobou (60 % národního mediánu) a sociálním vyloučením")
cntry_levels <- aropes2 |> arrange(pct_eu_arope) |> pull(country)
aropes2 %>%
tidyr::pivot_longer(cols = c(pct_eu_arope, pct_national_arope)) %>%
mutate(name = case_when(
name == "pct_eu_arope" ~ "Podíl domácností v ohrožení EU chudobou (50 % evropského mediánu) a sociálním vyloučením",
name == "pct_national_arope" ~ "Podíl domácností v ohrožení národní chudobou (60 % národního mediánu) a sociálním vyloučením"
), country = factor(country, levels = rev(cntry_levels))) %>%
ggplot(., aes(x = country, y = value, fill = name)) +
geom_bar(stat = "identity", position = "dodge") +
scale_y_continuous(labels = scales::label_percent(suffix = " %")) +
scale_fill_manual(values = paleta_kategoricka(2)) +
coord_flip() +
theme_paq() +
guides(fill = guide_legend(nrow = 2)) +
labs(x = "", y = "")
save_plot(last_plot(),
"figs/arop/arope_bez_indikatoru.png")
arop_deprivation <- hh_r_silc_2023_national_arop |>
group_by(country) |>
summarise(
under_national_arop = wtd.mean(under_national_arop, hh_cross_weight) * 100,
under_eu_arop = wtd.mean(under_arop, hh_cross_weight) * 100,
material_deprivation = wtd.mean(severe_material_social_deprivation, hh_cross_weight) * 100
) |>
mutate(
country = fct_case_when(
country == "Bulgaria" ~ "Bulharsko",
country == "Hungary" ~ "Maďarsko",
country == "Slovakia" ~ "Slovensko",
country == "Greece" ~ "Řecko",
country == "Romania" ~ "Rumunsko",
country == "Croatia" ~ "Chorvatsko",
country == "Latvia" ~ "Lotyšsko",
country == "Lithuania" ~ "Litva",
country == "Portugal" ~ "Portugalsko",
country == "Estonia" ~ "Estonsko",
country == "Poland" ~ "Polsko",
country == "Czechia" ~ "Česko",
country == "Malta" ~ "Malta",
country == "Cyprus" ~ "Kypr",
country == "Spain" ~ "Španělsko",
country == "Slovenia" ~ "Slovinsko",
country == "Italy" ~ "Itálie",
country == "France" ~ "Francie",
country == "Germany" ~ "Německo",
country == "Sweden" ~ "Švédsko",
country == "Denmark" ~ "Dánsko",
country == "Belgium" ~ "Belgie",
country == "Netherlands" ~ "Nizozemsko",
country == "Finland" ~ "Finsko",
country == "Ireland" ~ "Irsko",
country == "Austria" ~ "Rakousko",
country == "Luxembourg" ~ "Lucembursko"
)
)
cor(arop_deprivation$under_national_arop, arop_deprivation$material_deprivation)
## [1] 0.105053
cor(arop_deprivation$under_eu_arop, arop_deprivation$material_deprivation)
## [1] 0.5996177
r2_label <- tibble(
x = 10,
y = 20,
label = "r<sup>2</sup>=0.01"
)
chart_national_depr <- ggplot(arop_deprivation, aes(x = under_national_arop, y = material_deprivation)) +
geom_point() +
geom_text_repel(aes(label = country)) +
geom_richtext(aes(x = x, y = y, label = label),
data = r2_label, hjust = 0,
fill = NA, label.colour = NA) +
geom_smooth(method = "lm", se = FALSE) +
scale_y_continuous(labels = scales::label_percent(scale = 1, suffix = " %")) +
scale_x_continuous(labels = scales::label_percent(scale = 1, suffix = " %")) +
# coord_equal() +
theme_paq() +
labs(x = "% domácností pod národní hranicí chudoby",
y = "% domácností ve vážné materiální nebo sociální deprivaci")
eu_r2_label <- tibble(
x = 3.4,
y = 20,
label = "r<sup>2</sup>=0.36"
)
chart_eu_depr <- ggplot(arop_deprivation, aes(x = under_eu_arop, y = material_deprivation)) +
geom_point() +
geom_text_repel(aes(label = country)) +
geom_smooth(method = "lm", se = FALSE) +
geom_richtext(aes(x = x, y = y, label = label),
data = eu_r2_label, hjust = 0,
fill = NA, label.colour = NA) +
# coord_equal() +
scale_y_continuous(labels = scales::label_percent(scale = 1, suffix = " %")) +
scale_x_continuous(labels = scales::label_percent(scale = 1, suffix = " %")) +
theme_paq() +
labs(x = "% domácností pod evropskou hranicí chudoby",
y = "% domácností ve vážné materiální nebo sociální deprivaci")
chart_national_depr | chart_eu_depr
save_plot(plot = last_plot(),
path = "figs/arop/scatter_arop_deprivation.png")
eu_dens <- density(hh_r_silc_2023_national_arop$income_disposable_eqi_ppp, n = 50000)
eu_density_df <- tibble(
country = "EU",
x = eu_dens$x,
y = eu_dens$y
)
density_df %>%
left_join(., country_q95, by = "country") %>%
filter(x <= q95) %>%
bind_rows(
.,
eu_density_df
) %>%
mutate(under_eu_arop = x < EU_MEDIAN_60PCT) %>%
mutate(
country = fct_case_when(
country == "Bulgaria" ~ "Bulharsko",
country == "Hungary" ~ "Maďarsko",
country == "Slovakia" ~ "Slovensko",
country == "Greece" ~ "Řecko",
country == "Romania" ~ "Rumunsko",
country == "Croatia" ~ "Chorvatsko",
country == "Latvia" ~ "Lotyšsko",
country == "Lithuania" ~ "Litva",
country == "Portugal" ~ "Portugalsko",
country == "Estonia" ~ "Estonsko",
country == "Poland" ~ "Polsko",
country == "Czechia" ~ "Česko",
country == "Malta" ~ "Malta",
country == "Cyprus" ~ "Kypr",
country == "Spain" ~ "Španělsko",
country == "Slovenia" ~ "Slovinsko",
country == "Italy" ~ "Itálie",
country == "France" ~ "Francie",
country == "Germany" ~ "Německo",
country == "Sweden" ~ "Švédsko",
country == "Denmark" ~ "Dánsko",
country == "Belgium" ~ "Belgie",
country == "Netherlands" ~ "Nizozemsko",
country == "Finland" ~ "Finsko",
country == "Ireland" ~ "Irsko",
country == "Austria" ~ "Rakousko",
country == "Luxembourg" ~ "Lucembursko",
country == "EU" ~ "EU"
),
under_eu_arop = factor(under_eu_arop, levels = c(TRUE, FALSE),
labels = c("Pod evropskou hranicí příjmové chudoby (60 % evropského mediánu)", "Nad evropskou hranicí chudoby"))
) %>%
ggplot(., aes(x = x, y = country,
height = y * 10000, fill = under_eu_arop)) +
geom_vline(xintercept = EU_MEDIAN_60PCT, colour = "red") +
geom_vline(xintercept = EU_MEDIAN_50PCT, colour = "darkred") +
# geom_vline(xintercept = CZ_MEDIAN_60PCT, colour = "blue") +
geom_ridgeline_gradient() +
scale_x_continuous(limits = c(0, 75000), labels = scales::comma_format(big.mark = " ")) +
scale_fill_manual(values = c("Pod evropskou hranicí příjmové chudoby (60 % evropského mediánu)" = "#ECB925",
"Nad evropskou hranicí chudoby" = "gray80")) +
theme_paq() +
# theme(legend.position = "none") +
labs(x = "Ekvivalizovaný příjem domácnosti ve standardu kupní síly", y = "") +
geom_curve(x = 51000, xend = EU_MEDIAN_50PCT + 500, y = 24, yend = 27,
curvature = -0.05, colour = "darkred",
arrow = arrow(length = unit(0.1, "cm"))) +
annotate("text", x = 62500, y = 24, label = "50 % evropského mediánu",
colour = "darkred") +
geom_curve(x = 51000, xend = EU_MEDIAN_60PCT + 500, y = 23, yend = 26,
curvature = -0.05, colour = "red",
arrow = arrow(length = unit(0.1, "cm"))) +
annotate("text", x = 62500, y = 23, label = "60 % evropského mediánu",
colour = "red") +
guides(fill = guide_legend(nrow = 2))
save_plot(plot = last_plot(),
path = "figs/arop/arop1_eu_arrows.png",
height_px = 600,
width_px = 600)
hh_r_silc_2023_national_arop %>%
group_by(country) %>%
summarise(
under_national_arop = wtd.mean(under_national_arop, hh_cross_weight),
under_eu_poverty = wtd.mean(under_eu_poverty, hh_cross_weight),
under_eu_arop = wtd.mean(under_arop, hh_cross_weight)
) %>%
mutate(
country = fct_case_when(
country == "Bulgaria" ~ "Bulharsko",
country == "Hungary" ~ "Maďarsko",
country == "Slovakia" ~ "Slovensko",
country == "Greece" ~ "Řecko",
country == "Romania" ~ "Rumunsko",
country == "Croatia" ~ "Chorvatsko",
country == "Latvia" ~ "Lotyšsko",
country == "Lithuania" ~ "Litva",
country == "Portugal" ~ "Portugalsko",
country == "Estonia" ~ "Estonsko",
country == "Poland" ~ "Polsko",
country == "Czechia" ~ "Česko",
country == "Malta" ~ "Malta",
country == "Cyprus" ~ "Kypr",
country == "Spain" ~ "Španělsko",
country == "Slovenia" ~ "Slovinsko",
country == "Italy" ~ "Itálie",
country == "France" ~ "Francie",
country == "Germany" ~ "Německo",
country == "Sweden" ~ "Švédsko",
country == "Denmark" ~ "Dánsko",
country == "Belgium" ~ "Belgie",
country == "Netherlands" ~ "Nizozemsko",
country == "Finland" ~ "Finsko",
country == "Ireland" ~ "Irsko",
country == "Austria" ~ "Rakousko",
country == "Luxembourg" ~ "Lucembursko",
country == "EU" ~ "EU"
)
) %>%
ggplot(., aes(x = under_national_arop, y = under_eu_poverty)) +
geom_point() +
geom_text_repel(aes(label = country)) +
geom_smooth(se = FALSE, method = "lm") +
scale_x_continuous(labels = scales::label_percent(scale = 100, suffix = " %")) +
scale_y_continuous(labels = scales::label_percent(scale = 100, suffix = " %")) +
theme_paq() +
labs(x = "Pod hranicí 60 % národního mediánu",
y = "Pod hranicí 50 % evropského mediánu")
save_plot(last_plot(), "figs/arop/arop_scatter.png",
width_px = 640, height_px = 640)
hh_r_silc_2023_national_arop |>
filter(!is.na(sum_deprived_items)) |>
mutate(r_sum_deprived_items = fct_case_when(
sum_deprived_items >= 10 ~ "10 a více",
sum_deprived_items >= 7 ~ "7-9",
sum_deprived_items >= 4 ~ "4-6",
sum_deprived_items >= 3 ~ "3-5",
sum_deprived_items >= 1 ~ "1-2",
sum_deprived_items == 0 ~ "0"
)) |>
group_by(country, r_sum_deprived_items, under_national_arop) |>
summarise(n = sum(hh_cross_weight)) |>
group_by(country, r_sum_deprived_items) |>
mutate(pct = n / sum(n) * 100) |>
ggplot(aes(x = r_sum_deprived_items, y = pct, fill = under_national_arop)) +
geom_bar(stat = "identity") +
coord_flip() +
facet_wrap(~country) +
theme_paq()
hh_r_silc_2023_national_arop |>
group_by(country, under_national_arop) |>
ggplot(aes(x = under_national_arop, y = sum_deprived_items, fill = under_national_arop)) +
geom_boxplot(outliers = FALSE) +
facet_wrap(~country) +
theme_paq()
hh_r_silc_2023_national_arop |>
filter(!is.na(sum_deprived_items)) |>
mutate(r_sum_deprived_items = fct_case_when(
sum_deprived_items >= 10 ~ "10 a více",
sum_deprived_items >= 7 ~ "7-9",
sum_deprived_items >= 4 ~ "4-6",
sum_deprived_items >= 3 ~ "3-5",
sum_deprived_items >= 1 ~ "1-2",
sum_deprived_items == 0 ~ "0"
)) |>
group_by(country, r_sum_deprived_items, under_arop) |>
summarise(n = sum(hh_cross_weight)) |>
group_by(country, r_sum_deprived_items) |>
mutate(pct = n / sum(n) * 100) |>
ggplot(aes(x = r_sum_deprived_items, y = pct, fill = under_arop)) +
geom_bar(stat = "identity") +
coord_flip() +
facet_wrap(~country) +
theme_paq()
hh_r_silc_2023_national_arop |>
group_by(country, under_arop) |>
ggplot(aes(x = under_arop, y = sum_deprived_items, fill = under_arop)) +
geom_boxplot(outliers = FALSE) +
facet_wrap(~country) +
theme_paq()
hh_r_silc_2023_national_arop |>
group_by(country, sum_deprived_items_wo_expenses, under_national_arop) |>
summarise(n = sum(hh_cross_weight)) |>
group_by(country, sum_deprived_items_wo_expenses) |>
mutate(pct = n / sum(n) * 100) |>
ggplot(aes(x = sum_deprived_items_wo_expenses, y = pct, fill = under_national_arop)) +
geom_bar(stat = "identity") +
coord_flip() +
facet_wrap(~country) +
theme_paq()
hh_r_silc_2023_national_arop |>
group_by(country, under_national_arop) |>
ggplot(aes(x = under_national_arop, y = sum_deprived_items_wo_expenses,
fill = under_national_arop)) +
geom_boxplot(outliers = FALSE) +
facet_wrap(~country) +
theme_paq()
hh_r_silc_2023_national_arop |>
group_by(country, sum_deprived_items_wo_expenses, under_arop) |>
summarise(n = sum(hh_cross_weight)) |>
group_by(country, sum_deprived_items_wo_expenses) |>
mutate(pct = n / sum(n) * 100) |>
ggplot(aes(x = sum_deprived_items_wo_expenses, y = pct, fill = under_arop)) +
geom_bar(stat = "identity") +
coord_flip() +
facet_wrap(~country) +
theme_paq()
hh_r_silc_2023_national_arop |>
group_by(country, under_arop) |>
ggplot(aes(x = under_arop, y = sum_deprived_items_wo_expenses,
fill = under_arop)) +
geom_boxplot(outliers = FALSE) +
facet_wrap(~country) +
theme_paq()
hh_r_silc_2023_national_arop |>
group_by(country) |>
summarise(
cor_eu_arop_deprivation = cor(under_arop, sum_deprived_items,
use = "pairwise.complete.obs", method = "spearman"),
cor_national_arop_deprivation = cor(under_national_arop, sum_deprived_items,
use = "pairwise.complete.obs", method = "spearman")
) |>
knitr::kable(digits = 2)
| country | cor_eu_arop_deprivation | cor_national_arop_deprivation |
|---|---|---|
| Austria | 0.17 | 0.31 |
| Belgium | 0.14 | 0.27 |
| Bulgaria | 0.46 | 0.30 |
| Croatia | 0.51 | 0.48 |
| Cyprus | 0.35 | 0.36 |
| Czechia | 0.37 | 0.28 |
| Denmark | 0.15 | 0.19 |
| Estonia | 0.34 | 0.32 |
| Finland | 0.25 | 0.27 |
| France | 0.28 | 0.33 |
| Germany | 0.23 | 0.27 |
| Greece | 0.53 | 0.43 |
| Hungary | 0.41 | 0.31 |
| Ireland | 0.15 | 0.32 |
| Italy | 0.26 | 0.27 |
| Latvia | 0.43 | 0.36 |
| Lithuania | 0.39 | 0.34 |
| Luxembourg | 0.13 | 0.36 |
| Malta | 0.20 | 0.21 |
| Netherlands | 0.15 | 0.27 |
| Poland | 0.38 | 0.32 |
| Portugal | 0.43 | 0.34 |
| Romania | 0.44 | 0.33 |
| Slovakia | 0.35 | 0.31 |
| Slovenia | 0.32 | 0.33 |
| Spain | 0.33 | 0.33 |
| Sweden | 0.25 | 0.26 |
bydleni_data <- hh_r_silc_2023_arop %>%
group_by(r_country, r_tenure_status) %>%
summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>%
filter(!is.na(r_tenure_status)) %>%
mutate(r_tenure_status = factor(r_tenure_status,
levels = c("Owner", "Tenant"),
labels = c("Majitelé", "Nájemníci")))
ggplot(bydleni_data, aes(x = r_tenure_status, y = pct_under_arop, fill = r_country)) +
geom_bar(stat = "identity", position = "dodge") +
scale_y_continuous(labels = scales::label_percent(scale = 1)) +
scale_fill_manual(values = paleta_kategoricka(2)) +
labs(x = "", y = "% domácností pod evropskou hranicí chudoby") +
coord_flip() +
theme_paq()
save_plot(last_plot(),
"figs/arop/tenants.png")
hh_r_silc_2023_arop %>%
group_by(country, r_tenure_status) %>%
summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>%
filter(!is.na(r_tenure_status)) %>%
ggplot(., aes(x = r_tenure_status, y = pct_under_arop)) +
geom_bar(stat = "identity") +
scale_y_continuous(labels = scales::label_percent(scale = 1)) +
labs(x = "", y = "% under EU AROP") +
coord_flip() +
facet_wrap(vars(country), ncol = 4) +
theme_paq()
# # arrange(pct_under_arop) %>%
# knitr::kable(., digits = 2, col.names = c("Country", "Tenure", "% under EU AROP"))
typ_domacnosti_data <- hh_r_silc_2023_arop %>%
group_by(r_country, typ_domacnosti) %>%
summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>%
# filter(!is.na(tenure_status)) %>%
mutate(typ_domacnosti = factor(typ_domacnosti, levels = c("Ostatní", "Samoživitel/ka s dětmi", "Samostatně žijící senior", "Dvojice seniorů", "Úplná domácnost s dětmi")))
ggplot(typ_domacnosti_data, aes(x = typ_domacnosti, y = pct_under_arop, fill = r_country)) +
geom_bar(stat = "identity", position = "dodge") +
scale_y_continuous(labels = scales::label_percent(scale = 1)) +
scale_fill_manual(values = paleta_kategoricka(2)) +
labs(x = "", y = "% domácností pod evropskou hranicí chudoby") +
coord_flip() +
theme_paq()
save_plot(last_plot(),
"figs/arop/typ_hh.png")
hh_r_silc_2023_arop %>%
group_by(r_country, low_work_intensity) %>%
mutate(low_work_intensity = as_factor(low_work_intensity)) |>
mutate(low_work_intensity = factor(low_work_intensity,
levels = c("Not applicable", "Low work intensity", "No low work intensity"),
labels = c("Domácnosti 65+", "Domácnosti s nízkou pracovní intenzitou",
"Ekonomicky aktivní domácnosti\n(bez nízké pracovní intenzity)")
)) |>
summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>%
# filter(!is.na(tenure_status)) %>%
ggplot(aes(x = low_work_intensity, y = pct_under_arop, fill = r_country)) +
geom_bar(stat = "identity", position = "dodge") +
scale_y_continuous(labels = scales::label_percent(scale = 1)) +
scale_fill_manual(values = paleta_kategoricka(2)) +
labs(x = "", y = "% domácností pod evropskou hranicí chudoby") +
coord_flip() +
theme_paq()
save_plot(last_plot(),
"figs/arop/typ_ea.png")
hh_r_silc_2023_arop %>%
group_by(country, typ_domacnosti) %>%
summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>%
# filter(!is.na(tenure_status)) %>%
ggplot(., aes(x = typ_domacnosti, y = pct_under_arop)) +
geom_bar(stat = "identity") +
scale_y_continuous(labels = scales::label_percent(scale = 1)) +
labs(x = "", y = "% under EU AROP") +
coord_flip() +
facet_wrap(vars(country), ncol = 4) +
theme_paq()
hh_r_silc_2023_arop %>%
group_by(r_country, region_typ) %>%
summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>%
filter(!is.na(region_typ)) %>%
ggplot(., aes(x = region_typ, y = pct_under_arop, fill = r_country)) +
geom_bar(stat = "identity", position = "dodge") +
scale_y_continuous(labels = scales::label_percent(scale = 1)) +
labs(x = "", y = "% under EU AROP") +
coord_flip() +
theme_paq()
hh_r_silc_2023_arop %>%
group_by(country, region_typ) %>%
summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>%
filter(!is.na(region_typ)) %>%
ggplot(., aes(x = region_typ, y = pct_under_arop)) +
geom_bar(stat = "identity") +
scale_y_continuous(labels = scales::label_percent(scale = 1)) +
labs(x = "", y = "% under EU AROP") +
coord_flip() +
facet_wrap(vars(country), ncol = 4) +
theme_paq()
hh_r_silc_2023_arop |>
group_by(r_country, econ_status) %>%
summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>%
filter(!is.na(econ_status)) %>%
ggplot(., aes(x = econ_status, y = pct_under_arop,
fill = r_country)) +
geom_bar(stat = "identity", position = "dodge") +
scale_y_continuous(labels = scales::label_percent(scale = 1)) +
labs(x = "", y = "% under EU AROP") +
coord_flip() +
theme_paq()
hh_r_silc_2023_arop |>
group_by(country, econ_status) %>%
summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>%
filter(!is.na(econ_status)) %>%
ggplot(., aes(x = econ_status, y = pct_under_arop)) +
geom_bar(stat = "identity") +
scale_y_continuous(labels = scales::label_percent(scale = 1)) +
labs(x = "", y = "% under EU AROP") +
coord_flip() +
facet_wrap(vars(country), ncol = 4) +
theme_paq()
vzdelani_data <- hh_r_silc_2023_arop %>%
# filter(hh_old == "Bez 65+") %>%
mutate(rr_education = fct_case_when(
r_education %in% c("First stage tertiary", "Second stage tertiary") ~ "Vysokoškolské",
r_education %in% c("Pre-primary", "Primary", "Lower secondary",
"Upper secondary", "Post-secondary non-tertiary") ~ "Střední a nižší"
)) %>%
group_by(r_country, rr_education) %>%
summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>%
filter(!is.na(rr_education))
ggplot(vzdelani_data, aes(x = rr_education, y = pct_under_arop, fill = r_country)) +
geom_bar(stat = "identity", position = "dodge") +
scale_y_continuous(labels = scales::label_percent(scale = 1)) +
labs(x = "", y = "% under EU AROP") +
coord_flip() +
theme_paq()
hh_r_silc_2023_arop %>%
filter(hh_old == "Bez 65+") %>%
mutate(rr_education = fct_case_when(
r_education %in% c("Pre-primary", "Primary") ~ "Základní a nedokončené základní",
r_education %in% c("Lower secondary", "Upper secondary") ~ "Střední",
r_education %in% c("Post-secondary non-tertiary", "First stage tertiary",
"Second stage tertiary") ~ "Vysokoškolské"
)) %>%
group_by(country, rr_education) %>%
summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>%
filter(!is.na(rr_education)) %>%
ggplot(., aes(x = rr_education, y = pct_under_arop)) +
geom_bar(stat = "identity") +
scale_y_continuous(labels = scales::label_percent(scale = 1)) +
labs(x = "", y = "% under EU AROP") +
coord_flip() +
facet_wrap(vars(country), ncol = 4) +
theme_paq()
##### Small multiple chart
bind_rows(
vzdelani_data |>
ungroup() |>
rename(category = rr_education) |>
mutate(indicator = "Vzdělání"),
bydleni_data |>
ungroup() |>
rename(category = r_tenure_status) |>
mutate(indicator = "Typ bydlení")
) |>
ggplot(aes(x = category, y = pct_under_arop, fill = r_country)) +
geom_bar(stat = "identity", position = "dodge") +
facet_wrap(indicator~., scales = "free") +
coord_flip()
g1 <- typ_domacnosti_data |>
ungroup() |>
rename(category = typ_domacnosti) |>
mutate(indicator = "Typ domácnosti") |>
ggplot(aes(x = category, y = pct_under_arop, fill = r_country)) +
geom_bar(stat = "identity", position = "dodge") +
coord_flip() +
labs(x = "", y = "% domácností", fill = "",
title = "typ domácnosti") +
theme(legend.position = "top") +
theme_paq() +
scale_fill_manual(values = paleta_kategoricka(2))
g2 <- vzdelani_data |>
ungroup() |>
rename(category = rr_education) |>
mutate(indicator = "Vzdělání") |>
ggplot(aes(x = category, y = pct_under_arop, fill = r_country)) +
geom_bar(stat = "identity", position = "dodge") +
coord_flip() +
labs(x = "", y = "% domácností", fill = "",
title = "vzdělání") +
theme(legend.position = "top") +
theme_paq() +
theme_paq() +
scale_fill_manual(values = paleta_kategoricka(2))
g3 <- bydleni_data |>
ungroup() |>
rename(category = r_tenure_status) |>
mutate(indicator = "Typ bydlení") |>
ggplot(aes(x = category, y = pct_under_arop, fill = r_country)) +
geom_bar(stat = "identity", position = "dodge") +
coord_flip() +
labs(x = "", y = "% domácností", fill = "",
title = "typ bydlení") +
theme(legend.position = "top") +
theme_paq() +
theme_paq() +
scale_fill_manual(values = paleta_kategoricka(2))
g1 + (g2 / g3) +
plot_layout(guides = 'collect') &
theme(legend.position='bottom')
save_plot(last_plot(), "figs/arop/cr_chudoba_skupiny.png")
tar_load(r_silc_2019)
hh_r_silc_2019 <- r_silc_2019 %>%
group_by(country, hh_id) %>%
mutate(
n_retired = sum(econ_status == "Retired", na.rm = TRUE),
n_employed = sum(econ_status == "Employed", na.rm = TRUE),
n_adults = sum(age >= 18),
n_old_age = sum(age >= 65),
income_disposable = if_else(income_disposable < 0, 0, income_disposable),
income_disposable_eqi = if_else(income_disposable_eqi < 0, 0, income_disposable_eqi)
) %>%
slice(1) %>%
ungroup() %>%
mutate(across(where(is.character), ~haven::as_factor(.x))) %>%
# filter out EU countries only
filter(!country %in% c("NO", "RS", "CH")) %>%
mutate(country = fct_case_when(
country == "AT" ~ "Austria",
country == "BE" ~ "Belgium",
country == "BG" ~ "Bulgaria",
country == "CY" ~ "Cyprus",
country == "CZ" ~ "Czechia",
country == "DE" ~ "Germany",
country == "DK" ~ "Denmark",
country == "EE" ~ "Estonia",
country == "EL" ~ "Greece",
country == "ES" ~ "Spain",
country == "FI" ~ "Finland",
country == "FR" ~ "France",
country == "HR" ~ "Croatia",
country == "HU" ~ "Hungary",
country == "IE" ~ "Ireland",
country == "IT" ~ "Italy",
country == "LT" ~ "Lithuania",
country == "LU" ~ "Luxembourg",
country == "LV" ~ "Latvia",
country == "MT" ~ "Malta",
country == "NL" ~ "Netherlands",
country == "PL" ~ "Poland",
country == "PT" ~ "Portugal",
country == "RO" ~ "Romania",
country == "SE" ~ "Sweden",
country == "SI" ~ "Slovenia",
country == "SK" ~ "Slovakia"
)) %>%
mutate(
hh_retired = fct_case_when(
n_retired == n_persons ~ "Plně důchodcovská domácnost",
n_retired > 0 ~ "Domácnost s důchodcem",
n_retired == 0 ~ "Domácnost bez důchodců"
),
hh_old = fct_case_when(
n_old_age == n_persons ~ "Všichni 65+",
n_old_age > 0 ~ "Alespoň jeden 65+",
n_old_age == 0 ~ "Bez 65+"
),
typ_domacnosti = fct_case_when(
n_adults == 2 & n_children > 0 ~ "Úplná domácnost s dětmi",
n_adults == 1 & n_children > 0 ~ "Samoživitel/ka s dětmi",
n_adults == 2 & hh_retired == "Plně důchodcovská domácnost" ~ "Dvojice seniorů",
n_adults == 1 & hh_retired == "Plně důchodcovská domácnost" ~ "Samostatně žijící senior",
TRUE ~ "Ostatní"
)
)
exchange_rates <- read_excel("data/exchange_rates.xlsx", sheet = 3, skip = 8) %>%
select(currency = TIME, exchange_rate_2018 = `2018`) %>%
filter(!is.na(currency)) %>%
mutate(country = case_when(
currency == "Bulgarian lev" ~ "Bulgaria",
currency == "Czech koruna" ~ "Czechia",
currency == "Danish krone" ~ "Denmark",
currency == "Hungarian forint" ~ "Hungary",
currency == "Polish zloty" ~ "Poland",
currency == "Romanian leu" ~ "Romania",
currency == "Swedish krona" ~ "Sweden"
)) %>%
filter(!is.na(country)) %>%
mutate(exchange_rate_2018 = as.numeric(exchange_rate_2018))
ppp_data <- read_excel("data/power_purchasing_parity_2decimals.xlsx") %>%
select(country = Country, ppp_2018 = `2018`)
ppp_adjusted <- left_join(ppp_data, exchange_rates, by = "country") %>%
mutate(ppp_2018_adjusted = if_else(
!is.na(exchange_rate_2018),
ppp_2018 / exchange_rate_2018,
ppp_2018
)) %>%
select(country, ppp_2018_adjusted)
hh_r_silc_2019_ppp <- left_join(hh_r_silc_2019, ppp_adjusted, by = "country") %>%
mutate(
income_disposable_eqi_ppp = income_disposable_eqi / ppp_2018_adjusted
)
EU_MEDIAN_PPP_2018 <- wtd.quantile(hh_r_silc_2019_ppp$income_disposable_eqi_ppp,
hh_r_silc_2019_ppp$hh_cross_weight, 0.5)
EU_MEDIAN_60PCT_2018 <- EU_MEDIAN_PPP_2018 * 0.6
hh_r_silc_2019_arop <- hh_r_silc_2019_ppp %>%
mutate(under_arop = income_disposable_eqi_ppp < EU_MEDIAN_60PCT_2018)
# hh_r_silc_2019_arop %>%
# group_by(country) %>%
# summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>%
# arrange(pct_under_arop) %>%
# knitr::kable(., digits = 2, col.names = c("Country", "% under EU AROP (2018)"))
full_join(
hh_r_silc_2019_arop %>%
group_by(country) %>%
summarise(pct_under_arop_2018 = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE)
* 100),
hh_r_silc_2023_arop %>%
group_by(country) %>%
summarise(pct_under_arop_2022 = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE)
* 100),
by = "country"
) %>%
mutate(diff = pct_under_arop_2022 - pct_under_arop_2018) %>%
knitr::kable(., digits = 2, col.names = c("Country", "% under AROP (2018)",
"% under AROP (2022)",
"Difference 2022-2018"))
| Country | % under AROP (2018) | % under AROP (2022) | Difference 2022-2018 |
|---|---|---|---|
| Austria | 7.19 | 6.43 | -0.76 |
| Belgium | 6.13 | 3.96 | -2.16 |
| Bulgaria | 66.41 | 59.87 | -6.54 |
| Croatia | 47.60 | 42.35 | -5.25 |
| Cyprus | 13.07 | 13.87 | 0.80 |
| Czechia | 26.42 | 21.68 | -4.74 |
| Denmark | 7.05 | 7.45 | 0.40 |
| Estonia | 37.84 | 39.24 | 1.40 |
| Finland | 8.47 | 10.35 | 1.88 |
| France | 7.30 | 11.14 | 3.84 |
| Germany | 10.96 | 10.84 | -0.13 |
| Greece | 50.86 | 48.06 | -2.80 |
| Hungary | 62.12 | 55.85 | -6.27 |
| Ireland | 5.11 | 4.73 | -0.38 |
| Italy | 19.70 | 17.92 | -1.78 |
| Latvia | 49.71 | 46.01 | -3.70 |
| Lithuania | 49.29 | 41.26 | -8.02 |
| Luxembourg | 5.65 | 3.12 | -2.54 |
| Malta | 17.00 | 17.39 | 0.39 |
| Netherlands | 7.38 | 7.49 | 0.11 |
| Poland | 40.59 | 26.87 | -13.72 |
| Portugal | 38.91 | 37.70 | -1.22 |
| Romania | 72.69 | 51.73 | -20.96 |
| Slovakia | 50.07 | 51.33 | 1.25 |
| Slovenia | 17.95 | 14.79 | -3.16 |
| Spain | 23.06 | 20.14 | -2.92 |
| Sweden | 13.06 | 15.21 | 2.14 |
hh_r_silc_2023_national_arop %>%
group_by(r_country, under_arop, severe_material_social_deprivation) %>%
mutate(severe_material_social_deprivation = as_factor(severe_material_social_deprivation),
under_arop = factor(under_arop, levels = c(TRUE, FALSE),
labels = c("Pod EU hranicí",
"Nad EU hranicí"))) %>%
summarise(wtd_n = sum(hh_cross_weight)) %>%
group_by(r_country, under_arop) %>%
mutate(pct = wtd_n / sum(wtd_n)) %>%
ungroup %>%
ggplot(aes(x = under_arop, y = pct, fill = severe_material_social_deprivation)) +
geom_bar(stat = "identity") +
coord_flip() +
scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) +
scale_y_continuous(labels = scales::label_percent()) +
facet_wrap(vars(r_country)) +
theme_paq() +
labs(x = "", y = "")
hh_r_silc_2023_national_arop %>%
group_by(country, under_arop, severe_material_social_deprivation) %>%
mutate(severe_material_social_deprivation = as_factor(severe_material_social_deprivation),
under_arop = factor(under_arop, levels = c(TRUE, FALSE),
labels = c("Pod EU hranicí",
"Nad EU hranicí"))) %>%
summarise(wtd_n = sum(hh_cross_weight)) %>%
group_by(country, under_arop) %>%
mutate(pct = wtd_n / sum(wtd_n)) %>%
ungroup %>%
ggplot(aes(x = under_arop, y = pct, fill = severe_material_social_deprivation)) +
geom_bar(stat = "identity") +
coord_flip() +
scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) +
scale_y_continuous(labels = scales::label_percent()) +
facet_wrap(vars(country), ncol = 4) +
theme_paq() +
labs(x = "", y = "")
hh_r_silc_2023_national_arop %>%
mutate(under_arop = factor(under_arop,
levels = c(FALSE, TRUE),
labels = c(
"Nad EU hranicí ohrožení chudobou",
"Pod EU hranicí ohrožení chudobou"))) %>%
group_by(r_country, sum_deprived_items, under_arop) %>%
summarise(wtd_n = sum(hh_cross_weight)) %>%
group_by(r_country, sum_deprived_items) %>%
mutate(pct = wtd_n / sum(wtd_n)) %>%
ungroup %>%
ggplot(aes(x = sum_deprived_items, y = pct, fill = under_arop)) +
geom_bar(stat = "identity") +
coord_flip() +
scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) +
scale_y_continuous(labels = scales::label_percent()) +
facet_wrap(vars(r_country)) +
theme_paq() +
labs(y = "", x = "Počet položek materiální a sociální deprivace") +
guides(fill = guide_legend(reverse = TRUE))
hh_r_silc_2023_national_arop %>%
mutate(under_arop = factor(under_arop,
levels = c(FALSE, TRUE),
labels = c(
"Nad EU hranicí ohrožení chudobou",
"Pod EU hranicí ohrožení chudobou"))) %>%
group_by(country, sum_deprived_items, under_arop) %>%
summarise(wtd_n = sum(hh_cross_weight)) %>%
group_by(country, sum_deprived_items) %>%
mutate(pct = wtd_n / sum(wtd_n)) %>%
ungroup %>%
ggplot(aes(x = sum_deprived_items, y = pct, fill = under_arop)) +
geom_bar(stat = "identity") +
coord_flip() +
scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) +
scale_y_continuous(labels = scales::label_percent()) +
facet_wrap(vars(country), ncol = 4) +
theme_paq() +
labs(y = "", x = "Počet položek materiální a sociální deprivace") +
guides(fill = guide_legend(reverse = TRUE))
hh_r_silc_2023_national_arop %>%
group_by(r_country, under_national_arop, severe_material_social_deprivation) %>%
mutate(severe_material_social_deprivation = as_factor(severe_material_social_deprivation),
under_national_arop = factor(under_national_arop, levels = c(TRUE, FALSE),
labels = c("Pod národní hranicí",
"Nad národní hranicí"))) %>%
summarise(wtd_n = sum(hh_cross_weight)) %>%
group_by(r_country, under_national_arop) %>%
mutate(pct = wtd_n / sum(wtd_n)) %>%
ungroup %>%
ggplot(aes(x = under_national_arop, y = pct, fill = severe_material_social_deprivation)) +
geom_bar(stat = "identity") +
coord_flip() +
scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) +
scale_y_continuous(labels = scales::label_percent()) +
facet_wrap(vars(r_country)) +
theme_paq()
hh_r_silc_2023_national_arop %>%
group_by(country, under_national_arop, severe_material_social_deprivation) %>%
mutate(severe_material_social_deprivation = as_factor(severe_material_social_deprivation),
under_national_arop = factor(under_national_arop, levels = c(TRUE, FALSE),
labels = c("Pod národní hranicí",
"Nad národní hranicí"))) %>%
summarise(wtd_n = sum(hh_cross_weight)) %>%
group_by(country, under_national_arop) %>%
mutate(pct = wtd_n / sum(wtd_n)) %>%
ungroup %>%
ggplot(aes(x = under_national_arop, y = pct, fill = severe_material_social_deprivation)) +
geom_bar(stat = "identity") +
coord_flip() +
scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) +
scale_y_continuous(labels = scales::label_percent()) +
facet_wrap(vars(country), ncol = 4) +
theme_paq()
hh_r_silc_2023_national_arop %>%
mutate(under_national_arop = factor(under_national_arop,
levels = c(FALSE, TRUE),
labels = c(
"Nad národní hranicí ohrožení chudobou",
"Pod národní hranicí ohrožení chudobou"))) %>%
group_by(r_country, sum_deprived_items, under_national_arop) %>%
summarise(wtd_n = sum(hh_cross_weight)) %>%
group_by(r_country, sum_deprived_items) %>%
mutate(pct = wtd_n / sum(wtd_n)) %>%
ungroup %>%
ggplot(aes(x = sum_deprived_items, y = pct, fill = under_national_arop)) +
geom_bar(stat = "identity") +
coord_flip() +
scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) +
scale_y_continuous(labels = scales::label_percent()) +
facet_wrap(vars(r_country)) +
theme_paq() +
labs(y = "", x = "Počet položek materiální a sociální deprivace") +
guides(fill = guide_legend(reverse = TRUE))
hh_r_silc_2023_national_arop %>%
mutate(under_national_arop = factor(under_national_arop,
levels = c(FALSE, TRUE),
labels = c(
"Nad národní hranicí ohrožení chudobou",
"Pod národní hranicí ohrožení chudobou"))) %>%
group_by(country, sum_deprived_items, under_national_arop) %>%
summarise(wtd_n = sum(hh_cross_weight)) %>%
group_by(country, sum_deprived_items) %>%
mutate(pct = wtd_n / sum(wtd_n)) %>%
ungroup %>%
ggplot(aes(x = sum_deprived_items, y = pct, fill = under_national_arop)) +
geom_bar(stat = "identity") +
coord_flip() +
scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) +
scale_y_continuous(labels = scales::label_percent()) +
facet_wrap(vars(country), ncol = 4) +
theme_paq() +
labs(y = "", x = "Počet položek materiální a sociální deprivace") +
guides(fill = guide_legend(reverse = TRUE))
recode_term <- function(x){
fct_case_when(
x == "under_eu_arop" ~ "Under EU AROP",
x == "under_eu_poverty" ~ "Under EU poverty line (50% median)",
x == "under_eu_70_boundary" ~ "Under EU 70% median",
x == "under_national_arop" ~ "Under national AROP",
x == "under_national_poverty" ~ "Under national poverty line (50% median)",
x == "under_national_70_boundary" ~ "Under national 70% median",
x == "severe_material_social_deprivation" ~ "Severe material and social deprivation",
x == "sum_deprived_items" ~ "Number of deprived items"
)
}
hh_r_silc_2023_national_arop %>%
select(under_eu_arop = under_arop,
under_eu_poverty,
under_eu_70_boundary,
under_national_poverty,
under_national_arop,
under_national_70_boundary = under_70_boundary,
severe_material_social_deprivation,
sum_deprived_items) %>%
mutate(across(everything(), as.numeric)) %>%
correlate(use = "pairwise.complete.obs", method = "pearson") %>%
select(term,
`Severe material and social deprivation` = severe_material_social_deprivation,
`Number of deprived items` = sum_deprived_items) %>%
mutate(term = recode_term(term)) %>%
arrange(term) %>%
filter(!term %in% c("Severe material and social deprivation",
"Number of deprived items")) %>%
gt() %>%
fmt_number(decimals = 3) %>%
tab_style(
style = list(cell_fill(color = "red")),
locations = cells_body(
column = `Number of deprived items`,
rows = `Number of deprived items` == max(`Number of deprived items`, na.rm = TRUE)
)
) %>%
tab_style(
style = list(cell_fill(color = "red")),
locations = cells_body(
column = `Severe material and social deprivation`,
rows = `Severe material and social deprivation` == max(`Severe material and social deprivation`, na.rm = TRUE)
)
)
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.224 | 0.377 |
| Under EU poverty line (50% median) | 0.229 | 0.355 |
| Under EU 70% median | 0.218 | 0.386 |
| Under national AROP | 0.221 | 0.326 |
| Under national poverty line (50% median) | 0.200 | 0.274 |
| Under national 70% median | 0.228 | 0.358 |
tables <- purrr::map(c("Czechia", "Rest of EU"), function(x) {
hh_r_silc_2023_national_arop %>%
mutate(r_country = if_else(country == "Czechia", "Czechia", "Rest of EU")) %>%
filter(r_country == x) %>%
select(r_country,
under_eu_arop = under_arop,
under_eu_poverty,
under_eu_70_boundary,
under_national_poverty,
under_national_arop,
under_national_70_boundary = under_70_boundary,
severe_material_social_deprivation,
sum_deprived_items) %>%
mutate(across(where(is.logical) | where(is.factor), as.numeric)) %>%
correlate(use = "pairwise.complete.obs", method = "pearson") %>%
select(term,
`Severe material and social deprivation` = severe_material_social_deprivation,
`Number of deprived items` = sum_deprived_items) %>%
mutate(term = recode_term(term)) %>%
arrange(term) %>%
filter(!term %in% c("Severe material and social deprivation",
"Number of deprived items")) %>%
gt() %>%
fmt_number(decimals = 3) %>%
tab_style(
style = list(cell_fill(color = "red")),
locations = cells_body(
column = `Number of deprived items`,
rows = `Number of deprived items` == max(`Number of deprived items`, na.rm = TRUE)
)
) %>%
tab_style(
style = list(cell_fill(color = "red")),
locations = cells_body(
column = `Severe material and social deprivation`,
rows = `Severe material and social deprivation` == max(`Severe material and social deprivation`, na.rm = TRUE)
)
) %>%
tab_header(
title = x
)
})
purrr::walk(tables, print)
| Czechia | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.209 | 0.382 |
| Under EU poverty line (50% median) | 0.223 | 0.335 |
| Under EU 70% median | 0.169 | 0.378 |
| Under national AROP | 0.228 | 0.334 |
| Under national poverty line (50% median) | 0.207 | 0.255 |
| Under national 70% median | 0.212 | 0.372 |
| Rest of EU | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.225 | 0.377 |
| Under EU poverty line (50% median) | 0.229 | 0.355 |
| Under EU 70% median | 0.221 | 0.387 |
| Under national AROP | 0.221 | 0.325 |
| Under national poverty line (50% median) | 0.199 | 0.274 |
| Under national 70% median | 0.229 | 0.358 |
countries <- unique(hh_r_silc_2023_national_arop$country)
tables <- purrr::map(countries, function(x) {
hh_r_silc_2023_national_arop %>%
filter(country == x) %>%
select(country,
under_eu_arop = under_arop,
under_eu_poverty,
under_eu_70_boundary,
under_national_poverty,
under_national_arop,
under_national_70_boundary = under_70_boundary,
severe_material_social_deprivation,
sum_deprived_items) %>%
mutate(across(where(is.logical) | where(is.factor), as.numeric)) %>%
correlate(use = "pairwise.complete.obs", method = "pearson") %>%
select(term,
`Severe material and social deprivation` = severe_material_social_deprivation,
`Number of deprived items` = sum_deprived_items) %>%
mutate(term = recode_term(term)) %>%
arrange(term) %>%
filter(!term %in% c("Severe material and social deprivation",
"Number of deprived items")) %>%
gt() %>%
fmt_number(decimals = 3) %>%
tab_style(
style = list(cell_fill(color = "red")),
locations = cells_body(
column = `Number of deprived items`,
rows = `Number of deprived items` == max(`Number of deprived items`, na.rm = TRUE)
)
) %>%
tab_style(
style = list(cell_fill(color = "red")),
locations = cells_body(
column = `Severe material and social deprivation`,
rows = `Severe material and social deprivation` == max(`Severe material and social deprivation`, na.rm = TRUE)
)
) %>%
tab_header(
title = x
)
})
purrr::walk(tables, print)
| Austria | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.125 | 0.175 |
| Under EU poverty line (50% median) | 0.063 | 0.101 |
| Under EU 70% median | 0.172 | 0.249 |
| Under national AROP | 0.194 | 0.320 |
| Under national poverty line (50% median) | 0.169 | 0.241 |
| Under national 70% median | 0.192 | 0.358 |
| Belgium | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.148 | 0.172 |
| Under EU poverty line (50% median) | 0.085 | 0.093 |
| Under EU 70% median | 0.208 | 0.282 |
| Under national AROP | 0.224 | 0.301 |
| Under national poverty line (50% median) | 0.181 | 0.213 |
| Under national 70% median | 0.261 | 0.377 |
| Bulgaria | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.267 | 0.423 |
| Under EU poverty line (50% median) | 0.287 | 0.427 |
| Under EU 70% median | 0.244 | 0.402 |
| Under national AROP | 0.273 | 0.322 |
| Under national poverty line (50% median) | 0.245 | 0.264 |
| Under national 70% median | 0.299 | 0.380 |
| Cyprus | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.144 | 0.357 |
| Under EU poverty line (50% median) | 0.173 | 0.296 |
| Under EU 70% median | 0.167 | 0.414 |
| Under national AROP | 0.154 | 0.368 |
| Under national poverty line (50% median) | 0.164 | 0.299 |
| Under national 70% median | 0.161 | 0.409 |
| Czechia | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.209 | 0.382 |
| Under EU poverty line (50% median) | 0.223 | 0.335 |
| Under EU 70% median | 0.169 | 0.378 |
| Under national AROP | 0.228 | 0.334 |
| Under national poverty line (50% median) | 0.207 | 0.255 |
| Under national 70% median | 0.212 | 0.372 |
| Germany | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.154 | 0.234 |
| Under EU poverty line (50% median) | 0.114 | 0.173 |
| Under EU 70% median | 0.177 | 0.274 |
| Under national AROP | 0.176 | 0.272 |
| Under national poverty line (50% median) | 0.146 | 0.221 |
| Under national 70% median | 0.202 | 0.317 |
| Denmark | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.111 | 0.156 |
| Under EU poverty line (50% median) | 0.074 | 0.105 |
| Under EU 70% median | 0.155 | 0.200 |
| Under national AROP | 0.153 | 0.198 |
| Under national poverty line (50% median) | 0.111 | 0.156 |
| Under national 70% median | 0.162 | 0.223 |
| Estonia | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.134 | 0.319 |
| Under EU poverty line (50% median) | 0.137 | 0.316 |
| Under EU 70% median | 0.126 | 0.321 |
| Under national AROP | 0.144 | 0.319 |
| Under national poverty line (50% median) | 0.133 | 0.238 |
| Under national 70% median | 0.140 | 0.324 |
| Greece | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.310 | 0.499 |
| Under EU poverty line (50% median) | 0.348 | 0.498 |
| Under EU 70% median | 0.268 | 0.482 |
| Under national AROP | 0.363 | 0.452 |
| Under national poverty line (50% median) | 0.344 | 0.398 |
| Under national 70% median | 0.353 | 0.474 |
| Spain | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.246 | 0.343 |
| Under EU poverty line (50% median) | 0.224 | 0.300 |
| Under EU 70% median | 0.249 | 0.364 |
| Under national AROP | 0.245 | 0.343 |
| Under national poverty line (50% median) | 0.224 | 0.301 |
| Under national 70% median | 0.249 | 0.365 |
| Finland | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.106 | 0.222 |
| Under EU poverty line (50% median) | 0.046 | 0.131 |
| Under EU 70% median | 0.153 | 0.303 |
| Under national AROP | 0.116 | 0.249 |
| Under national poverty line (50% median) | 0.060 | 0.156 |
| Under national 70% median | 0.158 | 0.317 |
| France | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.223 | 0.309 |
| Under EU poverty line (50% median) | 0.160 | 0.219 |
| Under EU 70% median | 0.268 | 0.384 |
| Under national AROP | 0.250 | 0.358 |
| Under national poverty line (50% median) | 0.191 | 0.264 |
| Under national 70% median | 0.273 | 0.414 |
| Croatia | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.200 | 0.458 |
| Under EU poverty line (50% median) | 0.237 | 0.484 |
| Under EU 70% median | 0.174 | 0.424 |
| Under national AROP | 0.279 | 0.491 |
| Under national poverty line (50% median) | 0.292 | 0.464 |
| Under national 70% median | 0.249 | 0.491 |
| Hungary | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.227 | 0.370 |
| Under EU poverty line (50% median) | 0.266 | 0.405 |
| Under EU 70% median | 0.183 | 0.324 |
| Under national AROP | 0.268 | 0.340 |
| Under national poverty line (50% median) | 0.258 | 0.300 |
| Under national 70% median | 0.303 | 0.406 |
| Ireland | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.082 | 0.137 |
| Under EU poverty line (50% median) | 0.044 | 0.083 |
| Under EU 70% median | 0.172 | 0.255 |
| Under national AROP | 0.202 | 0.311 |
| Under national poverty line (50% median) | 0.101 | 0.173 |
| Under national 70% median | 0.210 | 0.360 |
| Italy | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.186 | 0.272 |
| Under EU poverty line (50% median) | 0.170 | 0.236 |
| Under EU 70% median | 0.184 | 0.288 |
| Under national AROP | 0.187 | 0.278 |
| Under national poverty line (50% median) | 0.174 | 0.246 |
| Under national 70% median | 0.184 | 0.292 |
| Lithuania | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.183 | 0.370 |
| Under EU poverty line (50% median) | 0.202 | 0.363 |
| Under EU 70% median | 0.168 | 0.374 |
| Under national AROP | 0.201 | 0.340 |
| Under national poverty line (50% median) | 0.202 | 0.291 |
| Under national 70% median | 0.200 | 0.359 |
| Luxembourg | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.105 | 0.153 |
| Under EU poverty line (50% median) | 0.093 | 0.114 |
| Under EU 70% median | 0.107 | 0.165 |
| Under national AROP | 0.186 | 0.353 |
| Under national poverty line (50% median) | 0.196 | 0.324 |
| Under national 70% median | 0.185 | 0.364 |
| Latvia | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.222 | 0.405 |
| Under EU poverty line (50% median) | 0.236 | 0.406 |
| Under EU 70% median | 0.194 | 0.387 |
| Under national AROP | 0.251 | 0.379 |
| Under national poverty line (50% median) | 0.235 | 0.325 |
| Under national 70% median | 0.256 | 0.403 |
| Malta | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.138 | 0.200 |
| Under EU poverty line (50% median) | 0.132 | 0.162 |
| Under EU 70% median | 0.157 | 0.236 |
| Under national AROP | 0.156 | 0.217 |
| Under national poverty line (50% median) | 0.129 | 0.179 |
| Under national 70% median | 0.159 | 0.245 |
| Netherlands | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.060 | 0.129 |
| Under EU poverty line (50% median) | 0.023 | 0.085 |
| Under EU 70% median | 0.148 | 0.235 |
| Under national AROP | 0.181 | 0.288 |
| Under national poverty line (50% median) | 0.063 | 0.132 |
| Under national 70% median | 0.185 | 0.341 |
| Poland | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.175 | 0.355 |
| Under EU poverty line (50% median) | 0.192 | 0.336 |
| Under EU 70% median | 0.162 | 0.345 |
| Under national AROP | 0.193 | 0.329 |
| Under national poverty line (50% median) | 0.195 | 0.289 |
| Under national 70% median | 0.180 | 0.350 |
| Portugal | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.219 | 0.416 |
| Under EU poverty line (50% median) | 0.236 | 0.387 |
| Under EU 70% median | 0.203 | 0.422 |
| Under national AROP | 0.249 | 0.365 |
| Under national poverty line (50% median) | 0.225 | 0.299 |
| Under national 70% median | 0.235 | 0.387 |
| Romania | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.300 | 0.425 |
| Under EU poverty line (50% median) | 0.310 | 0.418 |
| Under EU 70% median | 0.285 | 0.427 |
| Under national AROP | 0.279 | 0.351 |
| Under national poverty line (50% median) | 0.247 | 0.316 |
| Under national 70% median | 0.312 | 0.399 |
| Sweden | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.137 | 0.245 |
| Under EU poverty line (50% median) | 0.112 | 0.191 |
| Under EU 70% median | 0.156 | 0.285 |
| Under national AROP | 0.152 | 0.261 |
| Under national poverty line (50% median) | 0.118 | 0.202 |
| Under national 70% median | 0.154 | 0.285 |
| Slovenia | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.212 | 0.369 |
| Under EU poverty line (50% median) | 0.174 | 0.263 |
| Under EU 70% median | 0.212 | 0.419 |
| Under national AROP | 0.214 | 0.372 |
| Under national poverty line (50% median) | 0.184 | 0.271 |
| Under national 70% median | 0.210 | 0.419 |
| Slovakia | ||
| term | Severe material and social deprivation | Number of deprived items |
|---|---|---|
| Under EU AROP | 0.174 | 0.319 |
| Under EU poverty line (50% median) | 0.251 | 0.387 |
| Under EU 70% median | 0.140 | 0.262 |
| Under national AROP | 0.276 | 0.351 |
| Under national poverty line (50% median) | 0.239 | 0.259 |
| Under national 70% median | 0.268 | 0.367 |
GINI:
- vzít ekvivalizované příjmy domácností - verifikovat si, zda nám sedí
GINI s veřejnými publikacemi Eurostat
- ✅ definice ekonomicky aktivní populace - srovnat bez GINI jen na
nich
- ✅ volnější - vyřadit plně důchodecké domácnosti - srovnání států bez
nich
- ✅ tvrdší - vyřadit domácnosti s alespoň 1 důchodeckým příjmem
- udělat 2D mapy států podle:
- ✅ celkový výše příjmů aktivní populace (PPS) x nerovnosti
příjmů
- Česko vyjde v kvadrantu malé příjmy, omezené (ale ne nejmenší
nerovnosti)
- nice to have, když to bude fungovat:
- lepší popis distribuce toho GINI - jiný ukazatel nerovnosti, zda není
daný tím, že GINI hodně reflektuje nerovnost ve středu?
- srovnání s majetkovým GINI
- vývoj GINIs
Gini podle eurostatu: https://ec.europa.eu/eurostat/databrowser/view/ilc_di12/default/table?lang=en
gini_2023 <- hh_r_silc_2023 %>%
group_by(country) %>%
summarise(
gini = Gini(income_disposable_eqi, hh_cross_weight, na.rm = TRUE) * 100,
gini_neeqi = Gini(income_disposable, hh_cross_weight, na.rm = TRUE) * 100
)
gini_2023 %>%
mutate(country = as.character(country)) %>%
arrange(country) %>%
select(-gini_neeqi) %>%
knitr::kable(., digits = 2)
| country | gini |
|---|---|
| Austria | 29.71 |
| Belgium | 25.63 |
| Bulgaria | 37.82 |
| Croatia | 32.43 |
| Cyprus | 30.74 |
| Czechia | 25.41 |
| Denmark | 29.14 |
| Estonia | 34.21 |
| Finland | 27.82 |
| France | 29.25 |
| Germany | 30.18 |
| Greece | 31.61 |
| Hungary | 29.58 |
| Ireland | 29.03 |
| Italy | 32.33 |
| Latvia | 36.23 |
| Lithuania | 38.14 |
| Luxembourg | 30.66 |
| Malta | 34.81 |
| Netherlands | 27.34 |
| Poland | 28.78 |
| Portugal | 35.20 |
| Romania | 30.24 |
| Slovakia | 20.94 |
| Slovenia | 25.49 |
| Spain | 31.90 |
| Sweden | 31.39 |
gini_2023_wo_pensioners <- hh_r_silc_2023 %>%
filter(!hh_retired %in% c("Plně důchodcovská domácnost", "Domácnost s důchodcem")) %>%
group_by(country) %>%
summarise(
gini_no_pensioners = Gini(income_disposable_eqi, hh_cross_weight,
na.rm = TRUE) * 100,
gini_no_pensioners_neeqi = Gini(income_disposable, hh_cross_weight,
na.rm = TRUE) * 100,
)
gini_2023_wo_full_pensioner_hh <- hh_r_silc_2023 %>%
filter(hh_retired != "Plně důchodcovská domácnost") %>%
group_by(country) %>%
summarise(
gini_no_full_pensioners = Gini(income_disposable_eqi, hh_cross_weight,
na.rm = TRUE) * 100,
gini_no_full_pensioners_neeqi = Gini(income_disposable, hh_cross_weight,
na.rm = TRUE) * 100,
)
gini_2023 %>%
full_join(gini_2023_wo_pensioners, by = "country") %>%
full_join(gini_2023_wo_full_pensioner_hh, by = "country") %>%
select(-ends_with("neeqi")) %>%
mutate(
diff_wo_pensioners = gini_no_pensioners - gini,
diff_wo_full_pensioners = gini_no_full_pensioners - gini
) %>%
mutate(across(where(is.numeric), ~round(.x, 2))) %>%
rename(`Stát` = country, `Gini` = gini,
`Gini bez domácností s důchodcem` = gini_no_pensioners,
`Gini bez důchodcovských domácností` = gini_no_full_pensioners,
`Rozdíl Gini bez důchodců - populační Gini` = diff_wo_pensioners,
`Rozdíl Gini bez důchodcovských domácností - populační Gini` = diff_wo_full_pensioners) %>%
datatable(options = list(
paging =FALSE,
searching=FALSE,
pageLength = 50))
gini_2023 %>%
full_join(gini_2023_wo_pensioners, by = "country") %>%
full_join(gini_2023_wo_full_pensioner_hh, by = "country") %>%
select(country, ends_with("neeqi")) %>%
mutate(
diff_wo_pensioners = gini_no_pensioners_neeqi - gini_neeqi,
diff_wo_full_pensioners = gini_no_full_pensioners_neeqi - gini_neeqi
) %>%
mutate(across(where(is.numeric), ~round(.x, 2))) %>%
rename(`Stát` = country, `Gini` = gini_neeqi,
`Gini bez domácností s důchodcem` = gini_no_pensioners_neeqi,
`Gini bez důchodcovských domácností` = gini_no_full_pensioners_neeqi,
`Rozdíl Gini bez důchodců - populační Gini` = diff_wo_pensioners,
`Rozdíl Gini bez důchodcovských domácností - populační Gini` = diff_wo_full_pensioners) %>%
datatable(options = list(
paging =FALSE,
searching = FALSE,
pageLength = -1))
gini_2023_wo_old <- hh_r_silc_2023 %>%
filter(!hh_old %in% c("Všichni 65+", "Alespoň jeden 65+")) %>%
group_by(country) %>%
summarise(gini_no_pensioners = Gini(income_disposable_eqi, hh_cross_weight, na.rm = TRUE) * 100)
gini_2023_wo_full_old_hh <- hh_r_silc_2023 %>%
filter(hh_old != "Všichni 65+") %>%
group_by(country) %>%
summarise(gini_no_full_pensioners = Gini(income_disposable_eqi, hh_cross_weight, na.rm = TRUE) * 100)
gini_2023 %>%
select(-ends_with("neeqi")) %>%
full_join(gini_2023_wo_old, by = "country") %>%
full_join(gini_2023_wo_full_old_hh, by = "country") %>%
mutate(
diff_wo_pensioners = gini_no_pensioners - gini,
diff_wo_full_pensioners = gini_no_full_pensioners - gini
) %>%
mutate(across(where(is.numeric), ~round(.x, 2))) %>%
rename(`Stát` = country, `Gini` = gini,
`Gini bez domácností s důchodcem` = gini_no_pensioners,
`Gini bez důchodcovských domácností` = gini_no_full_pensioners,
`Rozdíl Gini bez důchodců - populační Gini` = diff_wo_pensioners,
`Rozdíl Gini bez důchodcovských domácností - populační Gini` = diff_wo_full_pensioners) %>%
datatable(options = list(
paging =FALSE,
searching = FALSE,
pageLength = -1))
data_2d <- hh_r_silc_2023_ppp %>%
group_by(country) %>%
summarise(median_income_disposable_eqi_ppp =
wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.5)) %>%
ungroup %>%
left_join(., gini_2023, by = "country")
AVG_INCOME <- mean(data_2d$median_income_disposable_eqi_ppp)
AVG_GINI <- mean(data_2d$gini)
data_2d %>%
mutate(
country = fct_case_when(
country == "Bulgaria" ~ "Bulharsko",
country == "Hungary" ~ "Maďarsko",
country == "Slovakia" ~ "Slovensko",
country == "Greece" ~ "Řecko",
country == "Romania" ~ "Rumunsko",
country == "Croatia" ~ "Chorvatsko",
country == "Latvia" ~ "Lotyšsko",
country == "Lithuania" ~ "Litva",
country == "Portugal" ~ "Portugalsko",
country == "Estonia" ~ "Estonsko",
country == "Poland" ~ "Polsko",
country == "Czechia" ~ "Česko",
country == "Malta" ~ "Malta",
country == "Cyprus" ~ "Kypr",
country == "Spain" ~ "Španělsko",
country == "Slovenia" ~ "Slovinsko",
country == "Italy" ~ "Itálie",
country == "France" ~ "Francie",
country == "Germany" ~ "Německo",
country == "Sweden" ~ "Švédsko",
country == "Denmark" ~ "Dánsko",
country == "Belgium" ~ "Belgie",
country == "Netherlands" ~ "Nizozemsko",
country == "Finland" ~ "Finsko",
country == "Ireland" ~ "Irsko",
country == "Austria" ~ "Rakousko",
country == "Luxembourg" ~ "Lucembursko")) |>
ggplot(aes(x = gini, y = median_income_disposable_eqi_ppp)) +
geom_hline(yintercept = AVG_INCOME, colour = "gray60") +
geom_vline(xintercept = AVG_GINI, colour = "gray60") +
geom_point() +
geom_text_repel(aes(label = country)) +
labs(x = "Gini koeficient", y = "Mediánový ekvivalizovaný příjem domácnosti v PPP") +
theme_paq()
save_plot(last_plot(),
"figs/arop/gini.png")
data_2d_wo_old <- hh_r_silc_2023_ppp %>%
filter(!hh_old %in% c("Všichni 65+", "Alespoň jeden 65+")) %>%
group_by(country) %>%
summarise(median_income_disposable_eqi_ppp =
wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.5)) %>%
ungroup %>%
left_join(., gini_2023_wo_old, by = "country")
AVG_INCOME <- mean(data_2d_wo_old$median_income_disposable_eqi_ppp)
AVG_GINI <- mean(data_2d_wo_old$gini_no_pensioners)
data_2d_wo_old %>%
mutate(
country = fct_case_when(
country == "Bulgaria" ~ "Bulharsko",
country == "Hungary" ~ "Maďarsko",
country == "Slovakia" ~ "Slovensko",
country == "Greece" ~ "Řecko",
country == "Romania" ~ "Rumunsko",
country == "Croatia" ~ "Chorvatsko",
country == "Latvia" ~ "Lotyšsko",
country == "Lithuania" ~ "Litva",
country == "Portugal" ~ "Portugalsko",
country == "Estonia" ~ "Estonsko",
country == "Poland" ~ "Polsko",
country == "Czechia" ~ "Česko",
country == "Malta" ~ "Malta",
country == "Cyprus" ~ "Kypr",
country == "Spain" ~ "Španělsko",
country == "Slovenia" ~ "Slovinsko",
country == "Italy" ~ "Itálie",
country == "France" ~ "Francie",
country == "Germany" ~ "Německo",
country == "Sweden" ~ "Švédsko",
country == "Denmark" ~ "Dánsko",
country == "Belgium" ~ "Belgie",
country == "Netherlands" ~ "Nizozemsko",
country == "Finland" ~ "Finsko",
country == "Ireland" ~ "Irsko",
country == "Austria" ~ "Rakousko",
country == "Luxembourg" ~ "Lucembursko")) |>
ggplot(aes(x = gini_no_pensioners, y = median_income_disposable_eqi_ppp)) +
geom_hline(yintercept = AVG_INCOME, colour = "gray60") +
geom_vline(xintercept = AVG_GINI, colour = "gray60") +
geom_point() +
geom_text_repel(aes(label = country)) +
labs(x = "Gini koeficient", y = "Mediánový ekvivalizovaný příjem domácnosti v PPP") +
theme_paq()
save_plot(last_plot(),
"figs/arop/gini_bez_duchodcu.png")
# https://rev01ution.red/wp-content/uploads/2024/03/global-wealth-databook-2023-ubs.pdf
gini_property <- tribble(
~country, ~gini_property,
"Austria", 76.1,
"Belgium", 59.6,
"Bulgaria", 70.6,
"Croatia", 69.6,
"Cyprus", 78.4,
"Czechia", 78.5,
"Denmark", 73.6,
"Estonia", 73.1,
"Finland", 72.4,
"France", 70.3,
"Germany", 77.2,
"Greece", 68.1,
"Hungary", 67.7,
"Ireland", 79.9,
"Italy", 67.8,
"Latvia", 80.4,
"Lithuania", 70.6,
"Luxembourg", 64.8,
"Malta", 60.9,
"Netherlands", 78.8,
"Poland", 68.4,
"Portugal", 70.3,
"Romania", 69.3,
"Slovakia", 50.8,
"Slovenia", 64.4,
"Spain", 68.3,
"Sweden", 87.4
)
full_join(gini_2023, gini_property, by = "country") |>
mutate(country = fct_case_when(
country == "Bulgaria" ~ "Bulharsko",
country == "Hungary" ~ "Maďarsko",
country == "Slovakia" ~ "Slovensko",
country == "Greece" ~ "Řecko",
country == "Romania" ~ "Rumunsko",
country == "Croatia" ~ "Chorvatsko",
country == "Latvia" ~ "Lotyšsko",
country == "Lithuania" ~ "Litva",
country == "Portugal" ~ "Portugalsko",
country == "Estonia" ~ "Estonsko",
country == "Poland" ~ "Polsko",
country == "Czechia" ~ "Česko",
country == "Malta" ~ "Malta",
country == "Cyprus" ~ "Kypr",
country == "Spain" ~ "Španělsko",
country == "Slovenia" ~ "Slovinsko",
country == "Italy" ~ "Itálie",
country == "France" ~ "Francie",
country == "Germany" ~ "Německo",
country == "Sweden" ~ "Švédsko",
country == "Denmark" ~ "Dánsko",
country == "Belgium" ~ "Belgie",
country == "Netherlands" ~ "Nizozemsko",
country == "Finland" ~ "Finsko",
country == "Ireland" ~ "Irsko",
country == "Austria" ~ "Rakousko",
country == "Luxembourg" ~ "Lucembursko"
)) |>
ggplot(aes(x = gini, y = gini_property)) +
geom_point() +
geom_vline(xintercept = mean(gini_2023$gini), colour = "gray60") +
geom_hline(yintercept = mean(gini_property$gini_property), colour = "gray60") +
geom_text_repel(aes(label = country)) +
# geom_smooth(method = "lm") +
labs(x = "Gini příjmů", y = "Gini majetku", caption = "Zdroj: EU-SILC 2023 pro gini index příjmů, Global Wealth Databook 2023 pro Gini majetku") +
theme_paq()
save_plot(last_plot(), "figs/arop/gini_income_property.png")